jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1439 Commits
1 Branch
1 Tag
176 MiB
 
 
 
 
 
 
Tree: 08804abfc4
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '08804abfc4'
${ noResults }
punkshell/src/vendormodules/pattern2-2.0.tm

911 lines
32 KiB
Raw Blame History

#PATTERN
# - A prototype-based Object system.
#
# Julian Noble 2003
# License: Public domain
#
# "I need pattern" - Lexx Series 1 Episode 3 - Eating Pattern.
#
#
# Pattern uses a mixture of class-based and prototype-based object instantiation.
#
# A pattern object has 'properties' and 'methods'
# The system makes a distinction between them with regards to the access syntax for write operations,
# and yet provides unity in access syntax for read operations.
# e.g >object . myProperty
# will return the value of the property 'myProperty'
# >ojbect . myMethod
# will return the result of the method 'myMethod'
# contrast this with the write operations:
# set [>object . myProperty .] blah
# >object . myMethod blah
# however, the property can also be read using:
# set [>object . myProperty .]
# Note the trailing . to give us a sort of 'reference' to the property.
# this is NOT equivalent to
# set [>object . myProperty]
# This last example is of course calling set against a standard variable whose name is whatever value is returned by reading the property
# i.e it is equivalent in this case to: set blah
#All objects are represented by a command, the name of which contains a leading ">".
#Any commands in the interp which use this naming convention are assumed to be a pattern object.
#Use of non-pattern commands containing this leading character is not supported. (Behaviour is undefined)
#All user-added properties & methods of the wrapped object are accessed
# using the separator character "."
#Metamethods supplied by the patterm system are accessed with the object command using the metamethod separator ".."
# e.g to instantiate a new object from an existing 'pattern' (the equivalent of a class or prototype)
# you would use the 'Create' metamethod on the pattern object like so:
# >MyFactoryClassOrPrototypeLikeThing .. Create >NameOfNewObject
# '>NameOfNewObject' is now available as a command, with certain inherited methods and properties
# of the object it was created from. (
#The use of the access-syntax separator character "." allows objects to be kept
# 'clean' in the sense that the only methods &/or properties that can be called this way are ones
# the programmer(you!) put there. Existing metamethods such as 'Create' are accessed using a different syntax
# so you are free to implement your own 'Create' method on your object that doesn't conflict with
# the metamethod.
#Chainability (or how to violate the Law of Demeter!)
#The . access-syntax gives TCL an OO syntax more closely in line with many OO systems in other
# languages such as Python & VB, and allows left to right keyboard-entry of a deeply nested object-reference
# structure, without the need to regress to enter matching brackets as is required when using
# standard TCL command syntax.
# ie instead of:
# [[[object nextObject] getItem 4] getItem [chooseItemNumber]] doSomething
# we can use:
# >object . nextObject . getItem 4 . getItem [chooseItemNumber] . doSomething
#
# This separates out the object-traversal syntax from the TCL command syntax.
# . is the 'traversal operator' when it appears between items in a commandlist
# . is the 'reference operator' when it is the last item in a commandlist
# , is the 'index traversal operator' (or 'nest operator') - mathematically it marks where there is a matrix 'partition'.
# It marks breaks in the multidimensional structure that correspond to how the data is stored.
# e.g obj . arraydata x y , x1 y1 z1
# represents an element of a 5-dimensional array structured as a plane of cubes
# e.g2 obj . arraydata x y z , x1 y1
# represents an element of a 5-dimensional array structured as a cube of planes
# The underlying storage for e.g2 might consist of something such as a Tcl array indexed such as cube($x,$y,$z) where each value is a patternlib::>matrix object with indices x1 y1
# .. is the 'meta-traversal operator' when it appears between items in a commandlist
# .. is the 'meta-info operator'(?) when it is the last item in a commandlist
#!todo - Duck Typing: http://en.wikipedia.org/wiki/Duck_typing
# implement iStacks & pStacks (interface stacks & pattern stacks)
#see also: Using namsepace ensemble without a namespace: http://wiki.tcl.tk/16975
#------------------------------------------------------------
# System objects.
#------------------------------------------------------------
#::pp::Obj-1 ::p::internals::>metaface
#::pp::Obj0 ::p::ifaces::>null
#::pp::Obj1 ::>pattern
#------------------------------------------------------------
#TODO
#investigate use of [namespace path ... ] to resolve command lookup (use it to chain iStacks?)
#CHANGES
#2018-09 - v 1.2.2
# varied refactoring
# Changed invocant datastructure curried into commands (the _ID_ structure)
# Changed MAP structure to dict
# Default Method no longer magic "item" - must be explicitly set with .. DefaultMethod (or .. PatternDefaultMethod for patterns)
# updated test suites
#2018-08 - v 1.2.1
# split ::p::predatorX functions into separate files (pkgs)
# e.g patternpredator2-1.0.tm
# patternpredator1-1.0 - split out but not updated/tested - probably obsolete and very broken
#
#2017-08 - v 1.1.6 Fairly big overhaul
# New predator function using coroutines
# Added bang operator !
# Fixed Constructor chaining
# Added a few tests to test::pattern
#
#2008-03 - preserve ::errorInfo during var writes
#2007-11
#Major overhaul + new functionality + new tests v 1.1
# new dispatch system - 'predator'.
# (preparing for multiple interface stacks, multiple invocants etc)
#
#
#2006-05
# Adjusted 'var' expansion to use the new tcl8.5 'namespace upvar $ns v1 n1 v2 n2 ... ' feature.
#
#2005-12
# Adjusted 'var' expansion in method/constructor etc bodies to be done 'inline' where it appears rather than aggregated at top.
#
# Fixed so that PatternVariable default applied on Create.
#
# unified interface/object datastructures under ::p::<id>:: instead of seperate ::p::IFACE::<id>::
# - heading towards multiple-interface objects
#
#2005-10-28
# 1.0.8.1 passes 80/80 tests
# >object .. Destroy - improved cleanup of interfaces & namespaces.
#
#2005-10-26
# fixes to refsync (still messy!)
# remove variable traces on REF vars during .. Destroy
# passes 76/76
#
#2005-10-24
# fix objectRef_TraceHandler so that reading a property via an object reference using array syntax will call a PropertyRead function if defined.
# 1.0.8.0 now passes 75/76
#
#2005-10-19
# Command alias introduced by @next@ is now placed in the interfaces namespace. (was unnamespaced before)
# changed IFACE array names for level0 methods to be m-1 instead of just m. (now consistent with higher level m-X names)
# 1.0.8.0 (passes 74/76)
# tests now in own package
# usage:
# package require test::pattern
# test::p::list
# test::p::run ?nameglob? ?-version <value>?
#
#2005-09?-12
#
# fixed standalone 'var' statement in method bodies so that no implicit variable declarations added to proc.
# fixed @next@ so that destination method resolved at interface compile time instead of call time
# fixed @next@ so that on Create, .. PatternMethod x overlays existing method produced by a previous .. PatternMethod x.
# (before, the overlay only occured when '.. Method' was used to override.)
#
#
# miscellaneous tidy-ups
#
# 1.0.7.8 (passes 71/73)
#
#2005-09-10
# fix 'unknown' system such that unspecified 'unknown' handler represented by lack of (unknown) variable instead of empty string value
# this is so that a mixin with an unspecified 'unknown' handler will not undo a lowerlevel 'unknown' specificier.
#
#2005-09-07
# bugfix indexed write to list property
# bugfix Variable default value
# 1.0.7.7 (passes 70/72)
# fails:
# arrayproperty.test - array-entire-reference
# properties.test - property_getter_filter_via_ObjectRef
#
#2005-04-22
# basic fix to PatternPropertyRead dispatch code - updated tests (indexed case still not fixed!)
#
# 1.0.7.4
#
#2004-11-05
# basic PropertyRead implementation (non-indexed - no tests!)
#
#2004-08-22
# object creation speedups - (pattern::internals::obj simplified/indirected)
#
#2004-08-17
# indexed property setter fixes + tests
# meta::Create fixes - state preservation on overlay (correct constructor called, property defaults respect existing values)
#
#2004-08-16
# PropertyUnset & PatternPropertyUnset metaMethods (filter method called on property unset)
#
#2004-08-15
# reference syncing: ensure writes to properties always trigger traces on property references (+ tests)
# - i.e method that updates o_myProp var in >myObj will cause traces on [>myObj . myProp .] to trigger
# - also trigger on curried traces to indexed properties i.e list and array elements.
# - This feature presumably adds some overhead to all property writes - !todo - investigate desirability of mechanism to disable on specific properties.
#
# fix (+ tests) for ref to multiple indices on object i.e [>myObj key1 key2 .]
#
#2004-08-05
# add PropertyWrite & PatternPropertyWrite metaMethods - (filter method called on property write)
#
# fix + add tests to support method & property of same name. (method precedence)
#
#2004-08-04
# disallow attempt to use method reference as if it were a property (raise error instead of silently setting useless var)
#
# 1.0.7.1
# use objectref array access to read properties even when some props unset; + test
# unset property using array access on object reference; + test
#
#
#2004-07-21
# object reference changes - array property values appear as list value when accessed using upvared array.
# bugfixes + tests - properties containing lists (multidimensional access)
#
#1.0.7
#
#2004-07-20
# fix default property value append problem
#
#2004-07-17
# add initial implementation of 'Unknown' and 'PatternUnknown' meta-methods
# (
#
#2004-06-18
# better cleanup on '>obj .. Destroy' - recursively destroy objects under parents subnamespaces.
#
#2004-06-05
# change argsafety operator to be anything with leading -
# if standalone '-' then the dash itself is not added as a parameter, but if a string follows '-'
# i.e tkoption style; e.g -myoption ; then in addition to acting as an argsafety operator for the following arg,
# the entire dash-prefixed operator is also passed in as an argument.
# e.g >object . doStuff -window .
# will call the doStuff method with the 2 parameters -window .
# >object . doStuff - .
# will call doStuff with single parameter .
# >object . doStuff - -window .
# will result in a reference to the doStuff method with the argument -window 'curried' in.
#
#2004-05-19
#1.0.6
# fix so custom constructor code called.
# update Destroy metamethod to unset $self
#
#1.0.4 - 2004-04-22
# bug fixes regarding method specialisation - added test
#
#------------------------------------------------------------
package provide pattern2 [namespace eval pattern {variable version; set version 2.0}]
package require patterncmd ;#utility/system diagnostic commands (may be used by metaface lib etc)
package require cmdline
package require patterndispatcher
namespace eval pattern {
variable initialised 0
}
namespace eval pp {
#this is also the interp alias namespace. (object commands created here , then renamed into place)
#the object aliases are named as incrementing integers.. !todo - consider uuids?
variable ID 0
namespace eval func {}
}
#!store all interface objects here?
namespace eval ::pp::ifaces {}
proc ::pp::assert {condition errmsg} {
if {![uplevel 1 expr $condition]} {
return -code error "assertion failed. condition:'$condition' msg:'$errmsg'"
}
}
#proc ::pp::assert args {}
proc ::pp::get_new_object_id {} {
tailcall incr ::pp::ID
#tailcall ::pattern::new_uuid
}
#create a new minimal object - with no interfaces or patterns.
proc ::pp::func::new_object {obj {OID ""}} {
puts stderr "(::pp::func::new_object) obj:$obj OID:$OID"
if {[string range $obj 0 1] ne "::"} {
set nsbase [uplevel 1 [list namespace current]]
if {$nsbase eq "::"} {
set obj ::$obj
} else {
set obj ${nsbase}::$obj
}
}
if {[info object isa object $obj]} {
puts stderr "(::pp::func::new_object) Object $obj already exists "
}
if {$OID eq ""} {
set OID [::pp::get_new_object_id]
}
set main_ns ::pp::Obj${OID}
if {[namespace exists $main_ns]} {
error "(::pp::func::new_object) Cannot create Object with id:'$OID' - corresponding namespace already exists"
}
set default_method {}
set object_command $obj
#set INVOCANTRECORD [list $OID $main_ns $default_method $object_command {}]
set invocantD [list id $OID ns $main_ns defaultmethod $default_method object $object_command]
# _ID_ structure
#set _InvocantData_ [dict create i [dict create this [list $INVOCANTRECORD]] context ""]
set _InvocantData_ [dict create i [dict create this [list $invocantD]] context ""]
#must create main varspace first as it is also the parent namespace for all varspaces
set vs_main [::pp::varspace_main create ::pp::Obj${OID} [set varspacename ""] $_InvocantData_]
set vs_meta [::pp::varspace_meta create ::pp::Obj${OID}::_meta _meta $_InvocantData_]
puts stderr "\t(::pp::func::new_object) --- about to call pp::dispatcher create $obj $_InvocantData_ main"
pp::dispatcher create $obj $_InvocantData_ "main"
return $obj
}
proc ::pp::func::new_dispatcher {obj _InvocantData_ apiname} {
pp::dispatcher create $obj $_InvocantData_ $apiname
}
#aliased from ::p::${OID}::
# called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something
proc ::pp::func::no_default_method {_ID_ args} {
puts stderr "no_default_method _ID_:'$_ID_' args:'$args'"
lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command wrapped
tailcall error "No default method on object $object_command. (To get or set, use: $object_command .. DefaultMethod ?methodname?)"
}
#>x .. Create >y
# ".." is special case equivalent to "._."
# (whereas in theory it would be ".default.")
# "." is equivalent to ".default." is equivalent to ".default.default." (.<iStack>.<iFace>.)
#>x ._. Create >y
#>x ._.default. Create >y ???
#
#
# create object using 'blah' as source interface-stack ?
#>x .blah. .. Create >y
#>x .blah,_. ._. Create .iStackDestination. >y
#
# ">x .blah,_." is a reference(cast) to >x that contains only the iStacks in the order listed. i.e [list blah _]
# the 1st item, blah in this case becomes the 'default' iStack.
#
#>x .*.
# cast to object with all iStacks
#
#>x .*,!_.
# cast to object with all iStacks except _
#
# ---------------------
#!todo - MultiMethod support via transient and persistent object conglomerations. Operators '&' & '@'
# - a persistent conglomeration will have an object id (OID) and thus associated namespace, whereas a transient one will not.
#
#eg1: >x & >y . some_multi_method arg arg
# this is a call to the MultiMethod 'some_multi_method' with 2 objects as the invocants. ('>x & >y' is a transient conglomeration of the two objects)
# No explicit 'invocation role' is specified in this call - so it gets the default role for multiple invocants: 'these'
# The invocant signature is thus {these 2}
# (the default invocation role for a standard call on a method with a single object is 'this' - with the associated signature {this 1})
# Invocation roles can be specified in the call using the @ operator.
# e.g >x & >y @ points . some_multi_method arg arg
# The invocant signature for this is: {points 2}
#
#eg2: {*}[join $objects &] @ objects & >p @ plane . move $path
# This has the signature {objects n plane 1} where n depends on the length of the list $objects
#
#
# To get a persistent conglomeration we would need to get a 'reference' to the conglomeration.
# e.g set pointset [>x & >y .]
# We can now call multimethods on $pointset
#
if {[namespace which ::pp::ifaces>null] eq ""} {
set ::pp::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface
#OID = 0
::pp::func::new_object ::pp::ifaces::>null 0
::pp::func::new_object ::>pattern 1
#'class' for ::pp::ifaces::>x instances
::pp::func::new_object ::pp::>interface 3
}
#NOOP - for compatibility with libraries which still call it
proc ::pattern::init {args} {
}
proc ::pattern::initXXX {args} {
if {[set ::pattern::initialised]} {
if {[llength $args]} {
#if callers want to avoid this error, they can do their own check of $::pattern::initialised
error "pattern package is already initialised. Unable to apply args: $args"
} else {
return 1
}
}
set ::pp::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface
#OID = 0
::pp::func::new_object ::pp::ifaces::>null 0
::pp::func::new_object ::>pattern 1
#'class' for ::pp::ifaces::>x instances
::pp::func::new_object ::pp::>interface 3
#::pp::>interface ## PatternSystem . add_pattern_interface 2
#add to constructor?
#::pp::Obj${o_OID}::_iface API(PatternInternal)add_tcloo_interface_on_api "varspace_iface" "pattern::IPatternInterface"
set ::pattern::initialised 1
}
# >pattern has object ID 1
# meta interface has object ID 0
proc ::pattern::init2 args {
if {[set ::pattern::initialised]} {
if {[llength $args]} {
#if callers want to avoid this error, they can do their own check of $::pattern::initialised
error "pattern package is already initialised. Unable to apply args: $args"
} else {
return 1
}
}
set ::pp::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface
#create metaface - IID = -1 - also OID = -1
# all objects implement this special interface - accessed via the .. operator.
package require metaface
#OID = 0
::pp::func::new_object ::p::ifaces::>null 0
#? null object has itself as level0 & level1 interfaces?
#set ::p::ifaces::>null [list [list 0 ::p::ifaces::>null item] [list [list 0] [list 0]] [list {} {}]]
#null interface should always have 'usedby' members. It should never be extended.
array set ::p::0::_iface::o_usedby [list i-1 ::p::internals::>metaface i0 ::p::ifaces::>null i1 ::>pattern] ;#'usedby' array
set ::p::0::_iface::o_open 0
set ::p::0::_iface::o_constructor [list]
set ::p::0::_iface::o_variables [list]
set ::p::0::_iface::o_properties [dict create]
set ::p::0::_iface::o_methods [dict create]
set ::p::0::_iface::o_varspace ""
set ::p::0::_iface::o_varspaces [list]
array set ::p::0::_iface::o_definition [list]
set ::p::0::_iface::o_propertyunset_handlers [dict create]
###############################
# OID = 1
# >pattern
###############################
::pp::func::new_object ::>pattern 1
set _self ::pattern
#set IFID [::p::internals::new_interface 1] ;#level 0 interface usedby object 1
#set IFID_1 [::p::internals::new_interface 1] ;#level 1 interface usedby object 1
#1)this object references its interfaces
#lappend ID $IFID $IFID_1
#set body [string map [::list @self@ ::>pattern @_self@ ::pattern @self_ID@ 0 @itemCmd@ item] $::p::internals::OBJECTCOMMAND]
#proc ::>pattern args $body
#######################################################################################
#OID = 2
# >ifinfo interface for accessing interfaces.
#
::p::internals::new_object ::p::ifaces::>2 "" 2 ;#>ifinfo object
set ::p::2::_iface::o_constructor [list]
set ::p::2::_iface::o_variables [list]
set ::p::2::_iface::o_properties [dict create]
set ::p::2::_iface::o_methods [dict create]
set ::p::2::_iface::o_varspace ""
set ::p::2::_iface::o_varspaces [list]
array set ::p::2::_iface::o_definition [list]
set ::p::2::_iface::o_open 1 ;#open for extending
::p::ifaces::>2 .. AddInterface 2
#Manually create a minimal >ifinfo implementation using the same general pattern we use for all method implementations
#(bootstrap because we can't yet use metaface methods on it)
proc ::p::2::_iface::isOpen.1 {_ID_} {
return $::p::2::_iface::o_open
}
interp alias {} ::p::2::_iface::isOpen {} ::p::2::_iface::isOpen.1
proc ::p::2::_iface::isClosed.1 {_ID_} {
return [expr {!$::p::2::_iface::o_open}]
}
interp alias {} ::p::2::_iface::isClosed {} ::p::2::_iface::isClosed.1
proc ::p::2::_iface::open.1 {_ID_} {
set ::p::2::_iface::o_open 1
}
interp alias {} ::p::2::_iface::open {} ::p::2::_iface::open.1
proc ::p::2::_iface::close.1 {_ID_} {
set ::p::2::_iface::o_open 0
}
interp alias {} ::p::2::_iface::close {} ::p::2::_iface::close.1
#proc ::p::2::_iface::(GET)properties.1 {_ID_} {
# set ::p::2::_iface::o_properties
#}
#interp alias {} ::p::2::_iface::(GET)properties {} ::p::2::_iface::(GET)properties.1
#interp alias {} ::p::2::properties {} ::p::2::_iface::(GET)properties
#proc ::p::2::_iface::(GET)methods.1 {_ID_} {
# set ::p::2::_iface::o_methods
#}
#interp alias {} ::p::2::_iface::(GET)methods {} ::p::2::_iface::(GET)methods.1
#interp alias {} ::p::2::methods {} ::p::2::_iface::(GET)methods
#link from object to interface (which in this case are one and the same)
#interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen [::p::ifaces::>2 --]
#interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed [::p::ifaces::>2 --]
#interp alias {} ::p::2::open {} ::p::2::_iface::open [::p::ifaces::>2 --]
#interp alias {} ::p::2::close {} ::p::2::_iface::close [::p::ifaces::>2 --]
interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen
interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed
interp alias {} ::p::2::open {} ::p::2::_iface::open
interp alias {} ::p::2::close {} ::p::2::_iface::close
#namespace eval ::p::2 "namespace export $method"
#######################################################################################
set ::pattern::initialised 1
::p::internals::new_object ::p::>interface "" 3
#create a convenience object on which to manipulate the >ifinfo interface
#set IF [::>pattern .. Create ::p::>interface]
set IF ::p::>interface
#!todo - put >ifinfo on a separate pStack so that end-user can more freely treat interfaces as objects?
# (or is forcing end user to add their own pStack/iStack ok .. ?)
#
::p::>interface .. AddPatternInterface 2 ;#
::p::>interface .. PatternVarspace _iface
::p::>interface .. PatternProperty methods
::p::>interface .. PatternPropertyRead methods {} {
varspace _iface
var {o_methods mmm}
return $mmm
}
::p::>interface .. PatternProperty properties
::p::>interface .. PatternPropertyRead properties {} {
varspace _iface
var o_properties
return $o_properties
}
::p::>interface .. PatternProperty variables
::p::>interface .. PatternProperty varspaces
::p::>interface .. PatternProperty definition
::p::>interface .. Constructor {{usedbylist {}}} {
#var this
#set this @this@
#set ns [$this .. Namespace]
#puts "-> creating ns ${ns}::_iface"
#namespace eval ${ns}::_iface {}
varspace _iface
var o_constructor o_variables o_properties o_methods o_definition o_usedby o_varspace o_varspaces
set o_constructor [list]
set o_variables [list]
set o_properties [dict create]
set o_methods [dict create]
set o_varspaces [list]
array set o_definition [list]
foreach usedby $usedbylist {
set o_usedby(i$usedby) 1
}
}
::p::>interface .. PatternMethod isOpen {} {
varspace _iface
var o_open
return $o_open
}
::p::>interface .. PatternMethod isClosed {} {
varspace _iface
var o_open
return [expr {!$o_open}]
}
::p::>interface .. PatternMethod open {} {
varspace _iface
var o_open
set o_open 1
}
::p::>interface .. PatternMethod close {} {
varspace _iface
var o_open
set o_open 0
}
::p::>interface .. PatternMethod refCount {} {
varspace _iface
var o_usedby
return [array size o_usedby]
}
set ::p::2::_iface::o_open 1
uplevel #0 {package require patternlib}
return 1
}
#detect attempt to treat a reference to a method as a property
proc ::pp::func::commandrefMisuse_TraceHandler {OID field args} {
#puts "commandrefMisuse_TraceHandler fired OID:$OID field:$field args:$args"
lassign [lrange $args end-2 end] vtraced vidx op
#NOTE! cannot rely on vtraced as it may have been upvared
switch -- $op {
write {
error "$field is not a property" "property ref write failure for property $field (OID: $OID refvariable: [lindex $args 0])"
}
unset {
#!todo - monitor stat of Tcl bug# 1911919 - when/(if?) fixed - reinstate 'unset' trace
#trace add variable $traced {read write unset} [concat ::pp::func::commandrefMisuse_TraceHandler $OID $field $args]
#!todo - don't use vtraced!
trace add variable $vtraced {read write unset array} [concat ::pp::func::commandrefMisuse_TraceHandler $OID $field $args]
#pointless raising an error as "Any errors in unset traces are ignored"
#error "cannot unset. $field is a method not a property"
}
read {
error "$field is not a property (args $args)" "property ref read failure for property $field (OID: $OID refvariable: [lindex $args 0])"
}
array {
error "$field is not a property (args $args)" "property ref use as array failure for property $field (OID: $OID refvariable: [lindex $args 0])"
#error "unhandled operation in commandrefMisuse_TraceHandler - got op:$op expected read,write,unset. OID:$OID field:$field args:$args"
}
}
return
}
#!todo - review calling-points for make_dispatcher.. probably being called unnecessarily at some points.
#
# The 'dispatcher' is an object instance's underlying object command.
#
#proc ::p::make_dispatcher {obj ID IFID} {
# proc [string map {::> ::} $obj] {{methprop INFO} args} [string map [::list @IID@ $IFID @oid@ $ID] {
# ::p::@IID@ $methprop @oid@ {*}$args
# }]
# return
#}
################################################################################################################################################
################################################################################################################################################
################################################################################################################################################
#force 1 will extend an interface even if shared. (??? why is this necessary here?)
#if IID empty string - create the interface.
proc ::pp::func::expand_interface {IID {force 0}} {
#puts stdout ">>> expand_interface $IID [info level -1]<<<"
if {![string length $IID]} {
set iid [expr {$::p::ID + 1}]
::pp::>interface .. Create ::pp::ifaces::>$iid
return $iid
} else {
if {[set ::pp::Obj${IID}::_iface::o_open]} {
#interface open for extending - shared or not!
return $IID
}
error "temporary error. Interface can't be expanded. Not implemented"
if {[array size ::pp::Obj${IID}::_iface::o_usedby] > 1} {
#upvar #0 ::p::${IID}::_iface::o_usedby prev_usedby
#oops.. shared interface. Copy before specialising it.
set prev_IID $IID
set IID [expr {$::pp::ID + 1}]
::pp::>interface .. Create ::pp::ifaces::>$IID
::pp::func::linkcopy_interface $prev_IID $IID
#assert: prev_usedby contains at least one other element.
}
#whether copied or not - mark as open for extending.
set ::pp::Obj${IID}::_iface::o_open 1
return $IID
}
}
#params: old - old (shared) interface ID
# new - new interface ID
proc ::pp::func::linkcopy_interface {old new} {
#puts stderr " ** ** ** linkcopy_interface $old $new"
set ns_old ::pp::Obj${old}::_iface
set ns_new ::pp::Obj${new}::_iface
foreach nsmethod [info commands ${ns_old}::*.1] {
#puts ">>> adding $nsmethod to iface $new"
set tail [namespace tail $nsmethod]
set method [string range $tail 0 end-2] ;#strip .1
if {![llength [info commands ${ns_new}::$method]]} {
set oldhead [interp alias {} ${ns_old}::$method] ;#the 'head' of the cmdchain that it actually points to ie $method.$x where $x >=1
#link from new interface namespace to existing one.
#(we assume that since ${ns_new}::$method didn't exist, that all the $method.$x chain slots are empty too...)
#!todo? verify?
#- actual link is chainslot to chainslot
interp alias {} ${ns_new}::$method.1 {} $oldhead
#!todo - review. Shouldn't we be linking entire chain, not just creating a single .1 pointer to the old head?
#chainhead pointer within new interface
interp alias {} ${ns_new}::$method {} ${ns_new}::$method.1
namespace eval $ns_new "namespace export $method"
#if {[string range $method 0 4] ni {(GET) (SET) (UNSE (CONS }} {
# lappend ${ns_new}::o_methods $method
#}
} else {
if {$method eq "(VIOLATE)"} {
#ignore for now
#!todo
continue
}
#!todo - handle how?
#error "command $cmd already exists in interface $new"
#warning - existing chainslot will be completely shadowed by linked method.
# - existing one becomes unreachable. #!todo review!?
error "linkcopy_interface $old -> $new - chainslot shadowing not implemented (method $method already exists on target interface $new)"
}
}
#foreach propinf [set ${ns_old}::o_properties] {
# lassign $propinf prop _default
# #interp alias {} ${ns_new}::(GET)$prop {} ::p::predator::getprop $prop
# #interp alias {} ${ns_new}::(SET)$prop {} ::p::predator::setprop $prop
# lappend ${ns_new}::o_properties $propinf
#}
set ${ns_new}::o_variables [set ${ns_old}::o_variables]
set ${ns_new}::o_properties [set ${ns_old}::o_properties]
set ${ns_new}::o_methods [set ${ns_old}::o_methods]
set ${ns_new}::o_constructor [set ${ns_old}::o_constructor]
set ::pp::${old}::_iface::o_usedby(i$new) linkcopy
#obsolete.?
#array set ::p::${new}:: [array get ::p::${old}:: ]
#!todo - is this done also when iface compiled?
#namespace eval ::p::${new}::_iface {namespace ensemble create}
#puts stderr "copy_interface $old $new"
#assume that the (usedby) data is now obsolete
#???why?
#set ${ns_new}::(usedby) [::list]
#leave ::(usedby) reference in place for caller to change as appropriate - 'copy'
return
}
################################################################################################################################################
################################################################################################################################################
################################################################################################################################################
#pattern::init
#return $::pattern::version
proc pp::repl {} {
set command ""
set prompt "% "
puts -nonewline stdout $prompt
flush stdout
while {[gets stdin line] >=0} {
append command "\n$line"
if {[info complete $command]} {
catch {uplevel #0 $command} result
puts stdout $result
set command ""
set prompt "% "
} else {
set prompt "(cont)% "
}
puts -nonewline stdout $prompt
flush stdout
}
}
if {[info exists ::argv0] && [file dirname [file normalize [info script]/ ]] eq [file dirname [file normalize $argv0/]]} {
pp::repl
}