1285 lines
41 KiB
1285 lines
41 KiB
#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::<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 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." (.<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 |
|
# |
|
|
|
|
|
|
|
|
|
|
|
|
|
#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
|
|
|