#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. #------------------------------------------------------------ #::p::-1 ::p::internals::>metaface #::p::0 ::p::ifaces::>null #::p::1 ::>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:::: instead of seperate ::p::IFACE:::: # - 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 ? # #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 pattern [namespace eval pattern {variable version; set version 1.2.4}] namespace eval pattern::util { # Generally better to use 'package require $minver-' # - this only gives us a different error proc package_require_min {pkg minver} { if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} { package require $pkg } else { error "Package pattern requires package $pkg of at least version $minver. Available: $available" } } } package require patterncmd 1.2.4- package require metaface 1.2.4- ;#utility/system diagnostic commands (may be used by metaface lib etc) #package require cmdline package require overtype #package require md5 ;#will be loaded if/when needed #package require md4 #package require uuid namespace eval pattern { variable initialised 0 if 0 { if {![catch {package require twapi_base} ]} { #twapi is a windows only package #MUCH faster to load just twapi_base than full 'package require twapi' IFF using the modular twapi distribution with multiple separately loadable dlls. # If available - windows seems to provide a fast uuid generator.. #*IF* tcllibc is missing, then as at 2008-05 twapi::new_uuid is significantly faster than uuid::uuid generate ( e.g 19 usec vs 76thousand usec! on 2.4GHZ machine) # (2018 update - 15-30usec vs ~200usec on core i9 @ ~2.6GHZ (time for a single call e.g time {pattern::new_uuid})) interp alias {} ::pattern::new_uuid {} ::twapi::new_uuid -localok } else { #performance on freebsd seems not great, but adequate. (e.g 500usec on dualcore 1.6GHZ) # (e.g 200usec 2018 corei9) #(with or without tcllibc?) #very first call is extremely slow though - 3.5seconds on 2018 corei9 package require uuid interp alias {} ::pattern::new_uuid {} ::uuid::uuid generate } #variable fastobj 0 ;#precalculated invocant ID in method body (instead of call time ) - removed for now - see pattern 1.2.1 (a premature optimisation which was hampering refactoring & advancement) } } namespace eval p { #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 internals {} #!?? #namespace export ?? variable coroutine_instance 0 } #------------------------------------------------------------------------------------- #review - what are these for? #note - this function is deliberately not namespaced # - it begins with the letters 'proc' (as do the created aliases) - to aid in editor's auto indexing/mapping features proc process_pattern_aliases {object args} { set o [namespace tail $object] interp alias {} process_patternmethod_$o {} [$object .. PatternMethod .] interp alias {} process_method_$o {} [$object .. Method .] interp alias {} process_constructor_$o {} [$object .. Constructor .] } #------------------------------------------------------------------------------------- #!store all interface objects here? namespace eval ::p::ifaces {} #K combinator - see http://wiki.tcl.tk/1923 #proc ::p::K {x y} {set x} #- not used - use inline K if desired i.e set x [lreplace $x[set x{}] $a $b blah] proc ::p::internals::(VIOLATE) {_ID_ violation_script} { #set out [::p::fixed_var_statements @IMPLICITDECLS@\n$violation_script] set processed [dict create {*}[::p::predator::expand_var_statements $violation_script]] if {![dict get $processed explicitvars]} { #no explicit var statements - we need the implicit ones set self [set ::p::${_ID_}::(self)] set IFID [lindex [set $self] 1 0 end] #upvar ::p::${IFID}:: self_IFINFO set varDecls {} set vlist [array get ::p::${IFID}:: v,name,*] set _k ""; set v "" if {[llength $vlist]} { append varDecls "upvar #0 " foreach {_k v} $vlist { append varDecls "::p::\${_ID_}::$v $v " } append varDecls "\n" } #set violation_script [string map [::list @IMPLICITDECLS@ $varDecls] $out] set violation_script $varDecls\n[dict get $processed body] #tidy up unset processed varDecls self IFID _k v } else { set violation_script [dict get $processed body] } unset processed #!todo - review (& document) exactly what context this script runs in and what vars/procs are/should be visible. eval "unset violation_script;$violation_script" } proc ::p::internals::DestroyObjectsBelowNamespace {ns} { #puts "\n##################\n#################### destroyObjectsBelowNamespace $ns\n" set nsparts [split [string trim [string map {:: :} $ns] :] :] if { ! ( ([llength $nsparts] == 3) & ([lindex $nsparts 0] == "p") & ([lindex $nsparts end] eq "_ref") )} { #ns not of form ::p::?::_ref foreach obj [info commands ${ns}::>*] { #catch {::p::meta::Destroy $obj} #puts ">>found object $obj below ns $ns - destroying $obj" $obj .. Destroy } } #set traces [trace info variable ${ns}::-->PATTERN_ANCHOR] #foreach tinfo $traces { # trace remove variable ${ns}::-->PATTERN_ANCHOR {*}$tinfo #} #unset -nocomplain ${ns}::-->PATTERN_ANCHOR foreach sub [namespace children $ns] { ::p::internals::DestroyObjectsBelowNamespace $sub } } ################################################# ################################################# ################################################# ################################################# ################################################# ################################################# ################################################# ################################################# ################################################# ################################################# proc ::p::get_new_object_id {} { tailcall incr ::p::ID #tailcall ::pattern::new_uuid } #create a new minimal object - with no interfaces or patterns. #proc ::p::internals::new_object [list cmd {wrapped ""} [list OID [expr {-2}]]] {} proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { #puts "-->new_object cmd:$cmd wrapped:$wrapped OID:$OID" if {$OID eq "-2"} { set OID [::p::get_new_object_id] #set OID [incr ::p::ID] ;#!todo - use uuids? (too slow?) (use uuids as configurable option?, pre-allocate a list of uuids?) #set OID [pattern::new_uuid] } #if $wrapped provided it is assumed to be an existing namespace. #if {[string length $wrapped]} { # #??? #} #sanity check - alias must not exist for this OID if {[llength [interp alias {} ::p::$OID]]} { error "Object alias '::p::$OID' already exists - cannot create new object with this id" } #system 'varspaces' - #until we have a version of Tcl that doesn't have 'creative writing' scope issues - # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. # (see http://wiki.tcl.tk/1030 'Dangers of creative writing') #set o_open 1 - every object is initially also an open interface (?) #NOTE! comments within namespace eval slow it down. namespace eval ::p::$OID { #namespace ensemble create namespace eval _ref {} namespace eval _meta {} namespace eval _iface { variable o_usedby; variable o_open 1; array set o_usedby [list]; variable o_varspace "" ; variable o_varspaces [list]; variable o_methods [dict create]; variable o_properties [dict create]; variable o_variables; variable o_propertyunset_handlers; set o_propertyunset_handlers [dict create] } } #set alias ::p::$OID #objectid alis default_method object_command wrapped_namespace set INVOCANTDATA [list $OID ::p::$OID "" $cmd $wrapped] #MAP is a dict set MAP [list invocantdata $INVOCANTDATA interfaces {level0 {} level0_default "" level1 {} level1_default ""} patterndata {patterndefaultmethod ""}] #NOTE 'interp alias' will prepend :: if chosen srccmd already exists as an alias token #we've already checked that ::p::$OID doesn't pre-exist # - so we know the return value of the [interp alias {} $alias {} ...] will be $alias #interp alias {} ::p::$OID {} ::p::internals::predator $MAP # _ID_ structure set invocants_dict [dict create this [list $INVOCANTDATA] ] #puts stdout "New _ID_structure: $interfaces_dict" set _ID_ [dict create i $invocants_dict context ""] interp alias {} ::p::$OID {} ::p::internals::predator $_ID_ #rename the command into place - thus the alias & the command name no longer match! rename ::p::$OID $cmd set ::p::${OID}::_meta::map $MAP # called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something interp alias {} ::p::${OID}:: {} ::p::internals::no_default_method $_ID_ #set p2 [string map {> ?} $cmd] #interp alias {} $p2 {} ::p::internals::alternative_predator $_ID_ #trace add command $cmd delete "$cmd .. Destroy ;#" #puts "@@@ trace add command $cmd rename [list $cmd .. Rename]" trace add command $cmd rename [list $cmd .. Rename] ;#will receive $oldname $newname "rename" #trace add command $cmd rename [$cmd .. Rename .] ;#EXTREMELY slow. (but why?) #puts "@@@ trace added for $cmd -> '[trace info command $cmd]'" #uplevel #0 "trace add command $cmd delete \"puts deleting$cmd ;#\"" #trace add command $cmd delete "puts deleting$cmd ;#" #puts stdout "trace add command $cmd delete \"puts deleting$cmd ;#\"" #puts "--> new_object returning map $MAP" return $MAP } #>x .. Create >y # ".." is special case equivalent to "._." # (whereas in theory it would be ".default.") # "." is equivalent to ".default." is equivalent to ".default.default." (...) #>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 # #set ::p::internals::predator to a particular predatorversion (from a patternpredatorX package) proc ::pattern::predatorversion {{ver ""}} { variable active_predatorversion set allowed_predatorversions {1 2} set default_predatorversion [lindex $allowed_predatorversions end] ;#default to last in list of allowed_predatorversions if {![info exists active_predatorversion]} { set first_time_set 1 } else { set first_time_set 0 } if {$ver eq ""} { #get version if {$first_time_set} { set active_predatorversions $default_predatorversion } return $active_predatorversion } else { #set version if {$ver ni $allowed_predatorversions} { error "Invalid attempt to set predatorversion - unknown value: $ver, try one of: $allowed_predatorversions" } if {!$first_time_set} { if {$active_predatorversion eq $ver} { #puts stderr "Active predator version is already '$ver'" #ok - nothing to do return $active_predatorversion } else { package require patternpredator$ver 1.2.4- if {![llength [info commands ::p::predator$ver]]} { error "Unable to set predatorversion - command ::p::predator$ver not found" } rename ::p::internals::predator ::p::predator$active_predatorversion } } package require patternpredator$ver 1.2.4- if {![llength [info commands ::p::predator$ver]]} { error "Unable to set predatorversion - command ::p::predator$ver not found" } rename ::p::predator$ver ::p::internals::predator set active_predatorversion $ver return $active_predatorversion } } ::pattern::predatorversion 2 # >pattern has object ID 1 # meta interface has object ID 0 proc ::pattern::init 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 } } #this seems out of date. # - where is PatternPropertyRead? # - Object is obsolete # - Coinjoin, Combine don't seem to exist array set ::p::metaMethods { Clone object Conjoin object Combine object Create object Destroy simple Info simple Object simple PatternProperty simple PatternPropertyWrite simple PatternPropertyUnset simple Property simple PropertyWrite simple PatternMethod simple Method simple PatternVariable simple Variable simple Digest simple PatternUnknown simple Unknown simple } array set ::p::metaProperties { Properties object Methods object PatternProperties object PatternMethods object } #create metaface - IID = -1 - also OID = -1 # all objects implement this special interface - accessed via the .. operator. set ::p::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface #OID = 0 ::p::internals::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 ############################### ::p::internals::new_object ::>pattern "" 1 #set ::>pattern [list [list 1 ::>pattern item] [list [list 0] [list 0]]] array set ::p::1::_iface::o_usedby [list] ;#'usedby' array 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 #lset SELFMAP 1 0 $IFID #lset SELFMAP 2 0 $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 alias} return $alias } ::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 {pattern::util::package_require_min patternlib 1.2.4} #uplevel #0 {package require patternlib} return 1 } proc ::p::merge_interface {old new} { #puts stderr " ** ** ** merge_interface $old $new" set ns_old ::p::$old set ns_new ::p::$new upvar #0 ::p::${new}:: IFACE upvar #0 ::p::${old}:: IFACEX if {![catch {set c_arglist $IFACEX(c,args)}]} { #constructor #for now.. just add newer constructor regardless of any existing one #set IFACE(c,args) $IFACEX(c,args) #if {![info exists IFACE(c,args)]} { # #target interface didn't have a constructor # #} else { # # #} } set methods [::list] foreach nm [array names IFACEX m-1,name,*] { lappend methods [lindex [split $nm ,] end] ;#use the method key-name not the value! (may have been overridden) } #puts " *** merge interface $old -> $new ****merging-in methods: $methods " foreach method $methods { if {![info exists IFACE(m-1,name,$method)]} { #target interface doesn't yet have this method set THISNAME $method if {![string length [info command ${ns_new}::$method]]} { if {![set ::p::${old}::_iface::o_open]} { #interp alias {} ${ns_new}::$method {} ${ns_old}::$method #namespace eval $ns_new "namespace export [namespace tail $method]" } else { #wait to compile } } else { error "merge interface - command collision " } #set i 2 ??? set i 1 } else { #!todo - handle how? #error "command $cmd already exists in interface $new" set i [incr IFACE(m-1,chain,$method)] set THISNAME ___system___override_${method}_$i #move metadata using subindices for delegated methods set IFACE(m-$i,name,$method) $IFACE(m-1,name,$method) set IFACE(m-$i,iface,$method) $IFACE(m-1,iface,$method) set IFACE(mp-$i,$method) $IFACE(mp-1,$method) set IFACE(m-$i,body,$method) $IFACE(m-1,body,$method) set IFACE(m-$i,args,$method) $IFACE(m-1,args,$method) #set next [::p::next_script $IFID0 $method] if {![string length [info command ${ns_new}::$THISNAME]]} { if {![set ::p::${old}::_iface::o_open]} { interp alias {} ${ns_new}::$THISNAME {} ${ns_old}::$method namespace eval $ns_new "namespace export $method" } else { #wait for compile } } else { error "merge_interface - command collision " } } array set IFACE [::list \ m-1,chain,$method $i \ m-1,body,$method $IFACEX(m-1,body,$method) \ m-1,args,$method $IFACEX(m-1,args,$method) \ m-1,name,$method $THISNAME \ m-1,iface,$method $old \ ] } #array set ${ns_new}:: [array get ${ns_old}::] #!todo - review #copy everything else across.. foreach {nm v} [array get IFACEX] { #puts "-.- $nm" if {([string first "m-1," $nm] != 0) && ($nm ne "usedby")} { set IFACE($nm) $v } } #!todo -write a test set ::p::${new}::_iface::o_open 1 #!todo - is this done also when iface compiled? #namespace eval ::p::$new {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 return } #detect attempt to treat a reference to a method as a property proc ::p::internals::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 ::p::internals::commandrefMisuse_TraceHandler $OID $field $args] #!todo - don't use vtraced! trace add variable $vtraced {read write unset array} [concat ::p::internals::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 #} ################################################################################################################################################ ################################################################################################################################################ ################################################################################################################################################ #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 ::p::internals::no_default_method {_ID_ args} { puts stderr "p::internals::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? or use PatternDefaultMethod)" } #force 1 will extend an interface even if shared. (??? why is this necessary here?) #if IID empty string - create the interface. proc ::p::internals::expand_interface {IID {force 0}} { #puts stdout ">>> expand_interface $IID [info level -1]<<<" if {![string length $IID]} { #return [::p::internals::new_interface] ;#new interface is by default open for extending (o_open = 1) set iid [expr {$::p::ID + 1}] ::p::>interface .. Create ::p::ifaces::>$iid return $iid } else { if {[set ::p::${IID}::_iface::o_open]} { #interface open for extending - shared or not! return $IID } if {[array size ::p::${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 [::p::internals::new_interface] set IID [expr {$::p::ID + 1}] ::p::>interface .. Create ::p::ifaces::>$IID ::p::internals::linkcopy_interface $prev_IID $IID #assert: prev_usedby contains at least one other element. } #whether copied or not - mark as open for extending. set ::p::${IID}::_iface::o_open 1 return $IID } } #params: old - old (shared) interface ID # new - new interface ID proc ::p::internals::linkcopy_interface {old new} { #puts stderr " ** ** ** linkcopy_interface $old $new" set ns_old ::p::${old}::_iface set ns_new ::p::${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 ::p::${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