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.
6411 lines
242 KiB
6411 lines
242 KiB
package require dictutils |
|
package provide metaface [namespace eval metaface { |
|
variable version |
|
set version 1.2.5 |
|
}] |
|
|
|
|
|
|
|
|
|
#example datastructure: |
|
#$_ID_ |
|
#{ |
|
#i |
|
# { |
|
# this |
|
# { |
|
# {16 ::p::16 item ::>x {}} |
|
# } |
|
# role2 |
|
# { |
|
# {17 ::p::17 item ::>y {}} |
|
# {18 ::p::18 item ::>z {}} |
|
# } |
|
# } |
|
#context {} |
|
#} |
|
|
|
#$MAP |
|
#invocantdata {16 ::p::16 item ::>x {}} |
|
#interfaces {level0 |
|
# { |
|
# api0 {stack {123 999}} |
|
# api1 {stack {333}} |
|
# } |
|
# level0_default api0 |
|
# level1 |
|
# { |
|
# } |
|
# level1_default {} |
|
# } |
|
#patterndata {patterndefaultmethod {}} |
|
|
|
|
|
namespace eval ::p::predator {} |
|
#temporary alternative to ::p::internals namespace. |
|
# - place predator functions here until ready to replace internals. |
|
|
|
|
|
namespace eval ::p::snap { |
|
variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks. |
|
} |
|
|
|
|
|
|
|
|
|
# not called directly. Retrieved using 'info body ::p::predator::getprop_template' |
|
#review - why use a proc instead of storing it as a string? |
|
proc ::p::predator::getprop_template {_ID_ args} { |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
if {"%varspace%" eq ""} { |
|
set ns ::p::${OID} |
|
} else { |
|
if {[string match "::*" "%varspace%"]} { |
|
set ns "%varspace%" |
|
} else { |
|
set ns ::p::${OID}::%varspace% |
|
} |
|
} |
|
|
|
|
|
if {[llength $args]} { |
|
#lassign [lindex $invocant 0] OID alias itemCmd cmd |
|
if {[array exists ${ns}::o_%prop%]} { |
|
#return [set ${ns}::o_%prop%($args)] |
|
if {[llength $args] == 1} { |
|
return [set ::p::${OID}::o_%prop%([lindex $args 0])] |
|
} else { |
|
return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]] |
|
} |
|
} else { |
|
set val [set ${ns}::o_%prop%] |
|
|
|
set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] |
|
if {$rType eq "object"} { |
|
#return [$val . item {*}$args] |
|
return [$val {*}$args] |
|
} else { |
|
#treat as list? |
|
return [lindex $val $args] |
|
} |
|
} |
|
} else { |
|
return [set ${ns}::o_%prop%] |
|
} |
|
} |
|
|
|
|
|
proc ::p::predator::getprop_template_immediate {_ID_ args} { |
|
if {[llength $args]} { |
|
if {[array exists %ns%::o_%prop%]} { |
|
return [set %ns%::o_%prop%($args)] |
|
} else { |
|
set val [set %ns%::o_%prop%] |
|
set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] |
|
if {$rType eq "object"} { |
|
#return [$val . item {*}$args] |
|
#don't assume defaultmethod named 'item'! |
|
return [$val {*}$args] |
|
} else { |
|
#treat as list? |
|
return [lindex $val $args] |
|
} |
|
} |
|
} else { |
|
return [set %ns%::o_%prop%] |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
proc ::p::predator::getprop_array {_ID_ prop args} { |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
|
|
#upvar 0 ::p::${OID}::o_${prop} prop |
|
#1st try: assume array |
|
if {[catch {array get ::p::${OID}::o_${prop}} result]} { |
|
#treat as list (why?) |
|
#!review |
|
if {[info exists ::p::${OID}::o_${prop}]} { |
|
array set temp [::list] |
|
set i 0 |
|
foreach element ::p::${OID}::o_${prop} { |
|
set temp($i) $element |
|
incr i |
|
} |
|
set result [array get temp] |
|
} else { |
|
error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" |
|
} |
|
} |
|
return $result |
|
} |
|
|
|
proc ::p::predator::setprop_template {prop _ID_ args} { |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
if {"%varspace%" eq ""} { |
|
set ns ::p::${OID} |
|
} else { |
|
if {[string match "::*" "%varspace%"]} { |
|
set ns "%varspace%" |
|
} else { |
|
set ns ::p::${OID}::%varspace% |
|
} |
|
} |
|
|
|
|
|
if {[llength $args] == 1} { |
|
#return [set ::p::${OID}::o_%prop% [lindex $args 0]] |
|
return [set ${ns}::o_%prop% [lindex $args 0]] |
|
|
|
} else { |
|
if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { |
|
#treat attempt to perform indexed write to nonexistant var, same as indexed write to array |
|
|
|
#2 args - single index followed by a value |
|
if {[llength $args] == 2} { |
|
return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] |
|
} else { |
|
#multiple indices |
|
#return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] |
|
return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] |
|
} |
|
} else { |
|
#treat as list |
|
return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] |
|
} |
|
} |
|
} |
|
|
|
#-------------------------------------- |
|
#property read & write traces |
|
#-------------------------------------- |
|
|
|
|
|
proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} { |
|
|
|
#puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' " |
|
|
|
#set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain. |
|
|
|
if {[llength $idx]} { |
|
if {[llength $idx] == 1} { |
|
set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx] |
|
} else { |
|
lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx] |
|
} |
|
return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value |
|
} else { |
|
if {![info exists $refname]} { |
|
set $refname [$get_cmd $_ID_ {*}$indices] |
|
} else { |
|
set newval [$get_cmd $_ID_ {*}$indices] |
|
if {[set $refname] ne $newval} { |
|
set $refname $newval |
|
} |
|
} |
|
return |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} { |
|
#note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname |
|
#puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" |
|
|
|
|
|
#derive the name of the write command from the ref var. |
|
set indices [lassign [split [namespace tail $refname] +] prop] |
|
|
|
|
|
#assert - we will never have both a list in indices and an idx value |
|
if {[llength $indices] && ($idx ne "")} { |
|
#since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x |
|
#review - are there any datastructures which would/should allow this? |
|
#this assertion is really just here as a sanity check for now |
|
error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" |
|
} |
|
|
|
#upvar #0 ::p::${OID}::_meta::map MAP |
|
#puts "-->propref_trace_write map: $MAP" |
|
|
|
#temporarily deactivate refsync trace |
|
#puts stderr -->1>--removing_trace_o_${field} |
|
### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] |
|
|
|
#we need to catch, and re-raise any error that we may receive when writing the property |
|
# because we have to reinstate the propvar_write_TraceHandler after the call. |
|
#(e.g there may be a propertywrite handler that deliberately raises an error) |
|
|
|
set excludesync_refs $refname |
|
set cmd ::p::${OID}::(SET)$prop |
|
|
|
|
|
set f_error 0 |
|
if {[catch { |
|
|
|
if {![llength $indices]} { |
|
if {[string length $idx]} { |
|
$cmd $_ID_ $idx [set ${refname}($idx)] |
|
#::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] |
|
### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] |
|
|
|
} else { |
|
$cmd $_ID_ [set $refname] |
|
### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] |
|
} |
|
} else { |
|
#puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" |
|
$cmd $_ID_ {*}$indices [set $refname] |
|
### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices |
|
} |
|
|
|
} result]} { |
|
set f_error 1 |
|
} |
|
|
|
|
|
|
|
|
|
#::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write |
|
#reactivate refsync trace |
|
#puts stderr "****** reactivating refsync trace on o_$field" |
|
#puts stderr -->2>--reactivating_trace_o_${field} |
|
### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] |
|
|
|
|
|
if {$f_error} { |
|
#!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. |
|
# ? return -code error $errMsg ? -errorinfo |
|
|
|
#!quick n dirty |
|
#error $errorMsg |
|
return -code error -errorinfo $::errorInfo $result |
|
} else { |
|
return $result |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
|
|
proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { |
|
#puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'" |
|
#NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array') |
|
|
|
set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set |
|
|
|
#set updated_value [::p::predator::getprop_array $prop $_ID_] |
|
#puts stderr "-->array_Trace updated_value:$updated_value" |
|
if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} { |
|
puts stderr "-->propref_trace_array error $errm" |
|
array set $refname {} |
|
} |
|
|
|
#return value ignored for |
|
} |
|
|
|
|
|
#-------------------------------------- |
|
# |
|
proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd |
|
|
|
|
|
#don't rely on variable name passed by trace - may have been 'upvar'ed |
|
set refvar ::p::${OID}::_ref::__OBJECT |
|
|
|
#puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar" |
|
|
|
set iflist [dict get $MAP interfaces level0] |
|
|
|
set plist [list] |
|
|
|
#!todo - get propertylist from cache on object(?) |
|
foreach IFID [lreverse $iflist] { |
|
dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { |
|
#lassign $pdef v |
|
if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} { |
|
if {[array exists ::p::${OID}::o_${prop}]} { |
|
lappend plist $prop [array get ::p::${OID}::o_${prop}] |
|
} else { |
|
#ignore - array only represents properties that have been set. |
|
#error "property $v is not set" |
|
#!todo - unset corresponding items in $refvar if needed? |
|
} |
|
} |
|
} |
|
} |
|
array set $refvar $plist |
|
} |
|
|
|
|
|
proc ::p::predator::object_read_trace {OID _ID_ vref idx op} { |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd |
|
#don't rely on variable name passed by trace. |
|
set refvar ::p::${OID}::_ref::__OBJECT |
|
|
|
#puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" |
|
|
|
#!todo? - build a list of all interface properties (cache it on object??) |
|
set iflist [dict get $MAP interfaces level0] |
|
set IID "" |
|
foreach id [lreverse $iflist] { |
|
if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { |
|
set IID $id |
|
break |
|
} |
|
} |
|
|
|
if {[string length $IID]} { |
|
#property |
|
if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { |
|
puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" |
|
} |
|
} else { |
|
#method |
|
error "property '$idx' not found" |
|
} |
|
} |
|
|
|
|
|
proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} { |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
lassign [dict get $MAP invocantdata] OID alias itemCmd |
|
|
|
#!todo - ??? |
|
|
|
if {![llength [info commands ::p::${OID}::$idx]]} { |
|
error "no such method or property: '$idx'" |
|
} else { |
|
#!todo? - build a list of all interface properties (cache it on object??) |
|
set iflist [dict get $MAP interfaces level0] |
|
set found 0 |
|
foreach id [lreverse $iflist] { |
|
if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { |
|
set found 1 |
|
break |
|
} |
|
} |
|
|
|
if {$found} { |
|
unset ::p::${OID}::o_$idx |
|
} else { |
|
puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" |
|
} |
|
} |
|
} |
|
|
|
|
|
proc ::p::predator::object_write_trace {OID _ID_ vref idx op} { |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd |
|
#don't rely on variable name passed by trace. |
|
set refvar ::p::${OID}::_ref::__OBJECT |
|
#puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" |
|
|
|
|
|
if {![llength [info commands ::p::${OID}::$idx]]} { |
|
#!todo - create new property in interface upon attempt to write to non-existant? |
|
# - or should we require some different kind of object-reference for that? |
|
array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx |
|
error "no such method or property: '$idx'" |
|
} else { |
|
#!todo? - build a list of all interface properties (cache it on object??) |
|
set iflist [dict get $MAP interfaces level0] |
|
set IID "" |
|
foreach id [lreverse $iflist] { |
|
if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { |
|
set IID $id |
|
break |
|
} |
|
} |
|
|
|
#$IID is now topmost interface in default iStack which has this property |
|
|
|
if {[string length $IID]} { |
|
#write to defined property |
|
|
|
::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] |
|
} else { |
|
#!todo - allow write of method body back to underlying object? |
|
#attempted write to 'method' ..undo(?) |
|
array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx |
|
error "cannot write to method '$idx'" |
|
#for now - disallow |
|
} |
|
} |
|
|
|
} |
|
|
|
|
|
|
|
proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} { |
|
#note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname |
|
|
|
set refindices [lassign [split [namespace tail $refname] +] prop] |
|
#derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop |
|
#if there is no PropertyUnset command - we unset the underlying variable directly |
|
|
|
trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] |
|
|
|
|
|
if {[catch { |
|
|
|
#assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value |
|
#i.e |
|
if {[llength $refindices] && [string length $idx]} { |
|
puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" |
|
error "unexpected call to propref_trace_unset" |
|
} |
|
|
|
|
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
set iflist [dict get $MAP interfaces level0] |
|
#find topmost interface containing this $prop |
|
set IID "" |
|
foreach id [lreverse $iflist] { |
|
if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { |
|
set IID $id |
|
break |
|
} |
|
} |
|
if {![string length $IID]} { |
|
error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
if {[string length $idx]} { |
|
#eval "$_alias ${unset_}$field $idx" |
|
#what happens to $refindices??? |
|
|
|
|
|
#!todo varspace |
|
|
|
if {![llength $refindices]} { |
|
#puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" |
|
|
|
if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { |
|
unset ::p::${OID}::o_${prop}($idx) |
|
} else { |
|
::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx |
|
} |
|
|
|
|
|
#manually call refsync, passing it this refvar as an exclusion |
|
::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx |
|
} else { |
|
#assert - won't get here |
|
error 1a |
|
|
|
} |
|
|
|
} else { |
|
if {[llength $refindices]} { |
|
#error 2a |
|
#puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" |
|
|
|
if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { |
|
#review - what about list-type property? |
|
#if {[array exists ::p::${OID}::o_${prop}]} ??? |
|
unset ::p::${OID}::o_${prop}($refindices) |
|
} else { |
|
::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices |
|
} |
|
|
|
|
|
|
|
#manually call refsync, passing it this refvar as an exclusion |
|
::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices |
|
|
|
|
|
} else { |
|
#puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" |
|
|
|
#ref is not of form prop+x etc and no idx in the trace - this is a plain unset |
|
if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { |
|
unset ::p::${OID}::o_${prop} |
|
} else { |
|
::p::${IID}::_iface::(UNSET)$prop $_ID_ "" |
|
} |
|
#manually call refsync, passing it this refvar as an exclusion |
|
::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} |
|
|
|
} |
|
} |
|
|
|
|
|
|
|
|
|
} errM]} { |
|
#set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" |
|
set ruler [string repeat - 80] |
|
puts stderr "\t$ruler" |
|
puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" |
|
puts stderr "\t$ruler" |
|
puts stderr $errM |
|
puts stderr "\t$ruler" |
|
|
|
} else { |
|
#puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" |
|
#puts stderr "*@*@*@*@ end propref_trace_unset - no error" |
|
} |
|
|
|
trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] |
|
|
|
|
|
} |
|
|
|
|
|
|
|
|
|
proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} { |
|
|
|
#Do not use 'info exists' (avoid triggering read trace) - use info vars |
|
if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { |
|
#puts " **> lappending '::p::REF::${OID}::$prop'" |
|
lappend refvars ::p::${OID}::_ref::$prop |
|
} |
|
lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] |
|
|
|
|
|
|
|
if {[string length $triggeringRef]} { |
|
set idx [lsearch -exact $refvars $triggeringRef] |
|
if {$idx >= 0} { |
|
set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] |
|
} |
|
} |
|
if {![llength $refvars]} { |
|
#puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" |
|
return |
|
} |
|
|
|
|
|
#*usually* triggeringRef is not in the reflist because the triggeringRef is being unset |
|
# - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" |
|
if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { |
|
#puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" |
|
puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" |
|
} |
|
|
|
|
|
puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " |
|
|
|
|
|
|
|
upvar $vtraced SYNCVARIABLE |
|
|
|
|
|
#We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars |
|
array set traces [::list] |
|
|
|
#puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" |
|
|
|
|
|
foreach rv $refvars { |
|
#puts "--refvar $rv" |
|
foreach tinfo [trace info variable $rv] { |
|
#puts "##trace $tinfo" |
|
set ops {}; set cmd {} |
|
lassign $tinfo ops cmd |
|
#!warning - assumes traces with single operation per handler. |
|
#write & unset traces on refvars need to be suppressed |
|
#we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. |
|
if {$ops in {read write unset array}} { |
|
if {[string match "::p::predator::propref_trace_*" $cmd]} { |
|
lappend traces($rv) $tinfo |
|
trace remove variable $rv $ops $cmd |
|
#puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" |
|
} |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
if {[array exists SYNCVARIABLE]} { |
|
|
|
#underlying variable is an array - we are presumably unsetting just an element |
|
set vtracedIsArray 1 |
|
} else { |
|
#!? maybe the var was an array - but it's been unset? |
|
set vtracedIsArray 0 |
|
} |
|
|
|
#puts stderr "--------------------------------------------------\n\n" |
|
#some things we don't want to repeat for each refvar in case there are lots of them.. |
|
|
|
#set triggeringRefIdx $vidx |
|
|
|
if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { |
|
set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] |
|
} else { |
|
set triggering_indices [list] |
|
} |
|
|
|
|
|
|
|
|
|
#puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" |
|
#puts stderr ">>> [trace info variable $vtraced]" |
|
#puts "--- unset branch refvar:$refvar" |
|
|
|
|
|
|
|
if {[llength $vidx]} { |
|
#trace called with an index - must be an array |
|
foreach refvar $refvars { |
|
set reftail [namespace tail $refvar] |
|
|
|
if {[string match "${prop}+*" $reftail]} { |
|
#!todo - add test |
|
if {$vidx eq [lrange [split $reftail +] 1 end]} { |
|
#unset if indices match |
|
error "untested, possibly unused branch spuds1" |
|
#puts "1111111111111111111111111" |
|
unset $refvar |
|
} |
|
} else { |
|
#test exists - #!todo - document which one |
|
|
|
#see if we succeeded in unsetting this element in the underlying variables |
|
#(may have been blocked by a PropertyUnset body) |
|
set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] |
|
#puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" |
|
if {$element_exists} { |
|
#do nothing it wasn't actually unset |
|
} else { |
|
#puts "JJJJJ unsetting ${refvar}($vidx)" |
|
unset ${refvar}($vidx) |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
|
|
} else { |
|
|
|
foreach refvar $refvars { |
|
set reftail [namespace tail $refvar] |
|
|
|
if {[string match "${prop}+*" $reftail]} { |
|
#check indices of triggering refvar match this refvars indices |
|
|
|
|
|
if {$reftail eq [namespace tail $triggeringRef]} { |
|
#!todo - add test |
|
error "untested, possibly unused branch spuds2" |
|
#puts "222222222222222222" |
|
unset $refvar |
|
} else { |
|
|
|
#error "untested - branch spuds2a" |
|
|
|
|
|
} |
|
|
|
} else { |
|
#!todo -add test |
|
#reference is directly to property var |
|
error "untested, possibly unused branch spuds3" |
|
#theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? |
|
puts "\t33333333333333333333" |
|
|
|
if {[string length $triggeringRefIdx]} { |
|
unset $refvar($triggeringRefIdx) |
|
} |
|
} |
|
} |
|
|
|
} |
|
|
|
|
|
|
|
|
|
#!todo - understand. |
|
#puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" |
|
#catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) |
|
|
|
|
|
#reinstall the traces we stored at the beginning of this proc. |
|
foreach rv [array names traces] { |
|
foreach tinfo $traces($rv) { |
|
set ops {}; set cmd {} |
|
lassign $tinfo ops cmd |
|
|
|
#puts stderr "****** re-installing setGet trace '$ops' on variable $rv" |
|
trace add variable $rv $ops $cmd |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
|
|
} |
|
|
|
|
|
proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} { |
|
|
|
upvar $vtraced SYNCVARIABLE |
|
|
|
set refvars [::list] |
|
#Do not use 'info exists' (avoid triggering read trace) - use info vars |
|
if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { |
|
lappend refvars ::p::${OID}::_ref::$prop |
|
} |
|
lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] |
|
|
|
|
|
|
|
#short_circuit breaks unset traces for array elements (why?) |
|
|
|
|
|
if {![llength $refvars]} { |
|
#puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" |
|
return |
|
} else { |
|
puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" |
|
} |
|
|
|
if {[catch { |
|
|
|
|
|
|
|
#We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars |
|
array set traces [::list] |
|
|
|
#puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" |
|
|
|
|
|
foreach rv $refvars { |
|
#puts "--refvar $rv" |
|
foreach tinfo [trace info variable $rv] { |
|
#puts "##trace $tinfo" |
|
set ops {}; set cmd {} |
|
lassign $tinfo ops cmd |
|
#!warning - assumes traces with single operation per handler. |
|
#write & unset traces on refvars need to be suppressed |
|
#we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. |
|
if {$ops in {read write unset array}} { |
|
if {[string match "::p::predator::propref_trace_*" $cmd]} { |
|
lappend traces($rv) $tinfo |
|
trace remove variable $rv $ops $cmd |
|
#puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" |
|
} |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
if {[array exists SYNCVARIABLE]} { |
|
|
|
#underlying variable is an array - we are presumably unsetting just an element |
|
set vtracedIsArray 1 |
|
} else { |
|
#!? maybe the var was an array - but it's been unset? |
|
set vtracedIsArray 0 |
|
} |
|
|
|
#puts stderr "--------------------------------------------------\n\n" |
|
#some things we don't want to repeat for each refvar in case there are lots of them.. |
|
set triggeringRefIdx $vidx |
|
|
|
|
|
|
|
#puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" |
|
#puts stderr ">>> [trace info variable $vtraced]" |
|
#puts "--- unset branch refvar:$refvar" |
|
|
|
|
|
|
|
if {[llength $vidx]} { |
|
#trace called with an index - must be an array |
|
foreach refvar $refvars { |
|
set reftail [namespace tail $refvar] |
|
|
|
if {[string match "${prop}+*" $reftail]} { |
|
#!todo - add test |
|
if {$vidx eq [lrange [split $reftail +] 1 end]} { |
|
#unset if indices match |
|
error "untested, possibly unused branch spuds1" |
|
#puts "1111111111111111111111111" |
|
unset $refvar |
|
} |
|
} else { |
|
#test exists - #!todo - document which one |
|
|
|
#see if we succeeded in unsetting this element in the underlying variables |
|
#(may have been blocked by a PropertyUnset body) |
|
set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] |
|
#puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" |
|
if {$element_exists} { |
|
#do nothing it wasn't actually unset |
|
} else { |
|
#puts "JJJJJ unsetting ${refvar}($vidx)" |
|
unset ${refvar}($vidx) |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
|
|
} else { |
|
|
|
foreach refvar $refvars { |
|
set reftail [namespace tail $refvar] |
|
unset $refvar |
|
|
|
} |
|
|
|
} |
|
|
|
|
|
|
|
|
|
#!todo - understand. |
|
#puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" |
|
#catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) |
|
|
|
|
|
#reinstall the traces we stored at the beginning of this proc. |
|
foreach rv [array names traces] { |
|
foreach tinfo $traces($rv) { |
|
set ops {}; set cmd {} |
|
lassign $tinfo ops cmd |
|
|
|
#puts stderr "****** re-installing setGet trace '$ops' on variable $rv" |
|
trace add variable $rv $ops $cmd |
|
} |
|
} |
|
|
|
} errM]} { |
|
set ruler [string repeat * 80] |
|
puts stderr "\t$ruler" |
|
puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" |
|
puts stderr "\t$ruler" |
|
puts stderr $::errorInfo |
|
puts stderr "\t$ruler" |
|
|
|
} |
|
|
|
} |
|
|
|
proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} { |
|
error hmmmmm |
|
upvar $vtraced SYNCVARIABLE |
|
#puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " |
|
set refvars [::list] |
|
|
|
#avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) |
|
if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { |
|
lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) |
|
} |
|
lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references |
|
#assert triggeringRef is in the list |
|
if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { |
|
error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" |
|
} |
|
set refposn [lsearch -exact $refvars $triggeringRef] |
|
#assert - due to test above, we know $triggeringRef is in the list so refposn > 0 |
|
set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] |
|
if {![llength $refvars]} { |
|
#puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" |
|
return [list refs_updates [list]] |
|
} |
|
|
|
#suppress the propref_trace_* traces on all refvars |
|
array set traces [::list] |
|
array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." |
|
#we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync |
|
#todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? |
|
#(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) |
|
|
|
foreach rv $refvars { |
|
#puts "--refvar $rv" |
|
foreach tinfo [trace info variable $rv] { |
|
#puts "##trace $tinfo" |
|
set ops {}; set cmd {} |
|
lassign $tinfo ops cmd |
|
#!warning - assumes traces with single operation per handler. |
|
#write & unset traces on refvars need to be suppressed |
|
#we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. |
|
|
|
|
|
if {[string match "::p::predator::propref_trace_*" $cmd]} { |
|
lappend traces($rv) $tinfo |
|
trace remove variable $rv $ops $cmd |
|
#puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" |
|
} else { |
|
#all other traces are 'external' |
|
lappend external_traces($rv) $tinfo |
|
#trace remove variable $rv $ops $cmd |
|
} |
|
|
|
} |
|
} |
|
#-------------------------------------------------------------------------------------------------------------------------- |
|
if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { |
|
if {![info exists SYNCVARIABLE]} { |
|
error "WARNING: REVIEW why does $vartraced not exist here?" |
|
} |
|
#either the underlying variable is an array |
|
# OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern |
|
set treat_vtraced_as_array 1 |
|
} else { |
|
set treat_vtraced_as_array 0 |
|
} |
|
|
|
set refs_updated [list] |
|
set refs_deleted [list] ;#unset due to index no longer being relevant |
|
if {$treat_vtraced_as_array} { |
|
foreach refvar $refvars { |
|
#puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" |
|
set refvar_tail [namespace tail $refvar] |
|
if {[string match "${prop}+*" $refvar_tail]} { |
|
#refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y |
|
set ref_indices [lrange [split $refvar_tail +] 1 end] |
|
if {[llength $indices]} { |
|
if {[llength $indices] == 1} { |
|
if {[lindex $ref_indices 0] eq [lindex $indices 0]} { |
|
#error "untested xxx-a" |
|
set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] |
|
lappend refs_updated $refvar |
|
} else { |
|
#test exists |
|
#error "xxx-ok single index" |
|
#updating a different part of the property - nothing to do |
|
} |
|
} else { |
|
#nested index |
|
if {[lindex $ref_indices 0] eq [lindex $indices 0]} { |
|
if {[llength $ref_indices] == 1} { |
|
#error "untested xxx-b1" |
|
set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] |
|
} else { |
|
#assert llength $ref_indices > 1 |
|
#NOTE - we cannot test index equivalence reliably/simply just by comparing indices |
|
#compare by value |
|
|
|
if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { |
|
#puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" |
|
if {[set $refvar] ne $possiblyNewVal} { |
|
set $refvar $possiblyNewVal |
|
} |
|
} else { |
|
#fail to retrieve underlying value corrsponding to these $indices |
|
unset $refvar |
|
} |
|
} |
|
} else { |
|
#test exists |
|
#error "untested xxx-ok deepindex" |
|
#updating a different part of the property - nothing to do |
|
} |
|
} |
|
} else { |
|
error "untested xxx-c" |
|
|
|
} |
|
|
|
} else { |
|
#refvar to update is plain e.g ::p::${OID}::_ref::${prop} |
|
if {[llength $indices]} { |
|
if {[llength $indices] == 1} { |
|
set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] |
|
} else { |
|
lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] |
|
} |
|
lappend refs_updated $refvar |
|
} else { |
|
error "untested yyy" |
|
set $refvar $SYNCVARIABLE |
|
} |
|
} |
|
} |
|
} else { |
|
#vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) |
|
# |
|
foreach refvar $refvars { |
|
#puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" |
|
set refvar_tail [namespace tail $refvar] |
|
if {[string match "${prop}+*" $refvar_tail]} { |
|
#refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y |
|
set ref_indices [lrange [split $refvar_tail +] 1 end] |
|
|
|
if {[llength $indices]} { |
|
#see if this update would affect this curried ref |
|
#1st see if we can short-circuit our comparison based on numeric-indices |
|
if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { |
|
#both sets of indices are purely numeric (no end end-1 etc) |
|
set rlen [llength $ref_indices] |
|
set ilen [llength $indices] |
|
set minlen [expr {min($rlen,$ilen)}] |
|
set matched_firstfew_indices 1 ;#assume the best |
|
for {set i 0} {$i < $minlen} {incr i} { |
|
if {[lindex $ref_indices $i] ne [lindex $indices $i]} { |
|
break ;# |
|
} |
|
} |
|
if {!$matched_firstfew_indices} { |
|
#update of this refvar not required |
|
#puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" |
|
break ;#break to next refvar in the foreach loop |
|
} |
|
} |
|
#failed to short-circuit |
|
|
|
#just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here |
|
set newval [lindex $SYNCVARIABLE $ref_indices] |
|
if {[set $refvar] ne $newval} { |
|
set $refvar $newval |
|
lappend refs_updated $refvar |
|
} |
|
|
|
} else { |
|
#we must be updating the entire variable - so this curried ref will either need to be updated or unset |
|
set newval [lindex $SYNCVARIABLE $ref_indices] |
|
if {[set ${refvar}] ne $newval} { |
|
set ${refvar} $newval |
|
lappend refs_updated $refvar |
|
} |
|
} |
|
} else { |
|
#refvar to update is plain e.g ::p::${OID}::_ref::${prop} |
|
if {[llength $indices]} { |
|
#error "untested zzz-a" |
|
set newval [lindex $SYNCVARIABLE $indices] |
|
if {[lindex [set $refvar] $indices] ne $newval} { |
|
lset ${refvar} $indices $newval |
|
lappend refs_updated $refvar |
|
} |
|
} else { |
|
if {[set ${refvar}] ne $SYNCVARIABLE} { |
|
set ${refvar} $SYNCVARIABLE |
|
lappend refs_updated $refvar |
|
} |
|
} |
|
|
|
} |
|
|
|
} |
|
} |
|
#-------------------------------------------------------------------------------------------------------------------------- |
|
|
|
#!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset |
|
|
|
#reinstall the traces we stored at the beginning of this proc. |
|
foreach rv [array names traces] { |
|
if {$rv ni $refs_deleted} { |
|
foreach tinfo $traces($rv) { |
|
set ops {}; set cmd {} |
|
lassign $tinfo ops cmd |
|
|
|
#puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" |
|
trace add variable $rv $ops $cmd |
|
} |
|
} |
|
} |
|
foreach rv [array names external_traces] { |
|
if {$rv ni $refs_deleted} { |
|
foreach tinfo $external_traces($rv) { |
|
set ops {}; set cmd {} |
|
lassign $tinfo ops cmd |
|
#trace add variable $rv $ops $cmd |
|
} |
|
} |
|
} |
|
|
|
|
|
return [list updated_refs $refs_updated] |
|
} |
|
|
|
#purpose: update all relevant references when context variable changed directly |
|
proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { |
|
#note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. |
|
#we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler |
|
|
|
upvar $vtraced SYNCVARIABLE |
|
#puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" |
|
set t_info [trace vinfo $vtraced] |
|
foreach t_spec $t_info { |
|
set t_ops [lindex $t_spec 0] |
|
if {$op in $t_ops} { |
|
puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" |
|
} |
|
} |
|
|
|
#puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- |
|
#vtype = array | array-item | list | simple |
|
|
|
set refvars [::list] |
|
|
|
############################ |
|
#!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! |
|
#This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) |
|
#The alternative 'info vars' does not trigger traces |
|
if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { |
|
#puts " **> lappending '::p::REF::${OID}::$prop'" |
|
lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) |
|
} |
|
############################ |
|
|
|
#lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) |
|
lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references |
|
|
|
|
|
if {![llength $refvars]} { |
|
#puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" |
|
return |
|
} |
|
|
|
|
|
#puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" |
|
|
|
#We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars |
|
array set predator_traces [::list] |
|
#maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. |
|
#ie for something like 'trace add variable someref {write read array} somefunc' |
|
# we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace |
|
array set external_read_traces [::list] ;#pure read traces the library user may have added |
|
array set external_readetc_traces [::list] ;#read + something else traces the library user may have added |
|
foreach rv $refvars { |
|
#puts "--refvar $rv" |
|
foreach tinfo [trace info variable $rv] { |
|
#puts "##trace $tinfo" |
|
set ops {}; set cmd {} |
|
lassign $tinfo ops cmd |
|
#!warning - assumes traces with single operation per handler. |
|
#write & unset traces on refvars need to be suppressed |
|
#we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. |
|
#if {$ops in {read write unset array}} {} |
|
|
|
if {[string match "::p::predator::propref_trace_*" $cmd]} { |
|
lappend predator_traces($rv) $tinfo |
|
trace remove variable $rv $ops $cmd |
|
#puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" |
|
} else { |
|
#other traces |
|
# puts "##trace $tinfo" |
|
if {"read" in $ops} { |
|
if {[llength $ops] == 1} { |
|
#pure read - |
|
lappend external_read_traces($rv) $tinfo |
|
trace remove variable $rv $ops $cmd |
|
} else { |
|
#mixed operation trace - remove and reinstall without the 'read' |
|
lappend external_readetc_traces($rv) $tinfo |
|
set other_ops [lsearch -all -inline -not $ops "read"] |
|
trace remove variable $rv $ops $cmd |
|
#reinstall trace for non-read operations only |
|
trace add variable $rv $other_ops $cmd |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
|
|
if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { |
|
#either the underlying variable is an array |
|
# OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern |
|
set vtracedIsArray 1 |
|
} else { |
|
set vtracedIsArray 0 |
|
} |
|
|
|
#puts stderr "--------------------------------------------------\n\n" |
|
|
|
#puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" |
|
#puts stderr ">>> [trace info variable $vtraced]" |
|
#puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" |
|
#puts "**write*********** refvars: $refvars" |
|
|
|
#!todo? unroll foreach into multiple foreaches within ifs? |
|
#foreach refvar $refvars {} |
|
|
|
|
|
#puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" |
|
if {[string length $vidx]} { |
|
#indexable |
|
if {$vtracedIsArray} { |
|
|
|
foreach refvar $refvars { |
|
#puts stderr " - - a refvar $refvar vidx: $vidx" |
|
set tail [namespace tail $refvar] |
|
if {[string match "${prop}+*" $tail]} { |
|
#refvar is curried |
|
#only set if vidx matches curried index |
|
#!todo -review |
|
set idx [lrange [split $tail +] 1 end] |
|
if {$idx eq $vidx} { |
|
set newval [set SYNCVARIABLE($vidx)] |
|
if {[set $refvar] ne $newval} { |
|
set ${refvar} $newval |
|
} |
|
#puts stderr "=a.1=> updated $refvar" |
|
} |
|
} else { |
|
#refvar is simple |
|
set newval [set SYNCVARIABLE($vidx)] |
|
if {![info exists ${refvar}($vidx)]} { |
|
#new key for this array |
|
#puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " |
|
array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] |
|
} else { |
|
set oldval [set ${refvar}($vidx)] |
|
if {$oldval ne $newval} { |
|
#puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " |
|
array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] |
|
} |
|
} |
|
#puts stderr "=a.2=> updated ${refvar} $vidx" |
|
} |
|
} |
|
|
|
|
|
|
|
} else { |
|
|
|
|
|
foreach refvar $refvars { |
|
upvar $refvar internal_property_reference |
|
#puts stderr " - - b vidx: $vidx" |
|
|
|
#!? could be object not list?? |
|
#!!but what is the difference between an object, and a list of object names which happens to only contain one object?? |
|
#For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) |
|
#There would still be an edge case of an initial write of a list of objects of length 1. |
|
if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { |
|
error "untested review!" |
|
#the o_prop is object-shaped |
|
#assumes object has a defaultmethod which accepts indices |
|
set newval [[set $SYNCVARIABLE] {*}$vidx] |
|
|
|
} else { |
|
set newval [lindex $SYNCVARIABLE {*}$vidx] |
|
#if {[set $refvar] ne $newval} { |
|
# set $refvar $newval |
|
#} |
|
if {$internal_property_reference ne $newval} { |
|
set internal_property_reference $newval |
|
} |
|
|
|
} |
|
#puts stderr "=b=> updated $refvar" |
|
} |
|
|
|
|
|
} |
|
|
|
|
|
|
|
} else { |
|
#no vidx |
|
|
|
if {$vtracedIsArray} { |
|
|
|
|
|
foreach refvar $refvars { |
|
set targetref_tail [namespace tail $refvar] |
|
set targetref_is_indexed [string match "${prop}+*" $targetref_tail] |
|
|
|
|
|
#puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" |
|
if {$targetref_is_indexed} { |
|
#curried array item ref of the form ${prop}+x or ${prop}+x+y etc |
|
|
|
#unindexed write on a property that is acting as an array.. |
|
|
|
#case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. |
|
|
|
#case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). |
|
# we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. |
|
puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" |
|
} else { |
|
#How do we know what to write to array ref? |
|
puts stderr "\tc.2 WARNING: unimplemented/unused?" |
|
#error no_tests_for_branch |
|
|
|
#warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation |
|
#if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate |
|
array unset ${refvar} |
|
array set ${refvar} [array get SYNCVARIABLE] |
|
} |
|
} |
|
|
|
|
|
|
|
} else { |
|
foreach refvar $refvars { |
|
#puts stderr "\t\t_________________[namespace current]" |
|
set targetref_tail [namespace tail $refvar] |
|
upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail |
|
set targetref_is_indexed [string match "${prop}+*" $targetref_tail] |
|
|
|
if {$targetref_is_indexed} { |
|
#puts "XXXXXXXXX vtraced:$vtraced" |
|
#reference curried with index(es) |
|
#we only set indexed refs if value has changed |
|
# - this not required to be consistent with standard list-containing variable traces, |
|
# as normally list elements can't be traced seperately anyway. |
|
# |
|
|
|
|
|
#only bother checking a ref if no setVia index |
|
# i.e some operation on entire variable so need to test synchronisation for each element-ref |
|
set targetref_indices [lrange [split $targetref_tail +] 1 end] |
|
set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] |
|
#puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" |
|
if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { |
|
set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal |
|
#puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" |
|
} |
|
|
|
|
|
} else { |
|
#for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! |
|
|
|
#puts stderr "- d2 set" |
|
#puts "refvar: [set $refvar]" |
|
#puts "SYNCVARIABLE: $SYNCVARIABLE" |
|
|
|
#if {[set $refvar] ne $SYNCVARIABLE} { |
|
# set $refvar $SYNCVARIABLE |
|
#} |
|
if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { |
|
set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE |
|
} |
|
|
|
} |
|
} |
|
|
|
|
|
} |
|
|
|
} |
|
|
|
|
|
|
|
|
|
#reinstall the traces we stored at the beginning of this proc. |
|
foreach rv [array names predator_traces] { |
|
foreach tinfo $predator_traces($rv) { |
|
set ops {}; set cmd {} |
|
lassign $tinfo ops cmd |
|
|
|
#puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" |
|
trace add variable $rv $ops $cmd |
|
} |
|
} |
|
|
|
foreach rv [array names external_traces] { |
|
foreach tinfo $external_traces($rv) { |
|
set ops {}; set cmd {} |
|
lassign $tinfo ops cmd |
|
|
|
#puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" |
|
trace add variable $rv $ops $cmd |
|
} |
|
} |
|
|
|
|
|
|
|
} |
|
|
|
# end propvar_write_TraceHandler |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# |
|
|
|
#returns 0 if method implementation not present for interface |
|
proc ::p::predator::method_chainhead {iid method} { |
|
#Interface proc |
|
# examine the existing command-chain |
|
set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex) |
|
set cmdchain [list] |
|
|
|
set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}] |
|
set maxversion 0 |
|
#loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob. |
|
foreach test [lsort -dictionary $candidates] { |
|
set c [namespace tail $test] |
|
if {[regexp $re $c _match version]} { |
|
lappend cmdchain $c |
|
if {$version > $maxversion} { |
|
set maxversion $version |
|
} |
|
} |
|
} |
|
return $maxversion |
|
} |
|
|
|
|
|
|
|
|
|
|
|
#this returns a script that upvars vars for all interfaces on the calling object - |
|
# - must be called at runtime from a method |
|
proc ::p::predator::upvar_all {_ID_} { |
|
#::set OID [lindex $_ID_ 0 0] |
|
::set OID [::lindex [::dict get $_ID_ i this] 0 0] |
|
::set decl {} |
|
#[set ::p::${OID}::_meta::map] |
|
#[dict get [lindex [dict get $_ID_ i this] 0 1] map] |
|
|
|
::upvar #0 ::p::${OID}::_meta::map MAP |
|
#puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" |
|
#set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] |
|
|
|
::foreach ifid [dict get $MAP interfaces level0] { |
|
if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} { |
|
::array unset nsvars |
|
::array set nsvars [::list] |
|
::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { |
|
::set varspace [::dict get $vinfo varspace] |
|
::lappend nsvars($varspace) $vname |
|
} |
|
#nsvars now contains vars grouped by varspace. |
|
|
|
::foreach varspace [::array names nsvars] { |
|
if {$varspace eq ""} { |
|
::set ns ::p::${OID} |
|
} else { |
|
if {[::string match "::*" $varspace]} { |
|
::set ns $varspace |
|
} else { |
|
::set ns ::p::${OID}::$varspace |
|
} |
|
} |
|
|
|
::append decl "namespace upvar $ns " |
|
::foreach vname [::set nsvars($varspace)] { |
|
::append decl "$vname $vname " |
|
} |
|
::append decl " ;\n" |
|
} |
|
::array unset nsvars |
|
} |
|
} |
|
::return $decl |
|
} |
|
|
|
#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator) |
|
proc ::p::predator::runtime_vardecls {} { |
|
set result "::eval \[::p::predator::upvar_all \$_ID_\]" |
|
#set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" |
|
|
|
#set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" |
|
#set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" |
|
#puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" |
|
return $result |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
#OBSOLETE!(?) - todo - move stuff out of here. |
|
proc ::p::predator::compile_interface {IFID caller_ID_} { |
|
upvar 0 ::p::${IFID}:: IFACE |
|
|
|
#namespace eval ::p::${IFID} { |
|
# namespace ensemble create |
|
#} |
|
|
|
#'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables |
|
|
|
namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces |
|
|
|
#set varDecls {} |
|
#if {[llength $o_variables]} { |
|
# #puts "*********!!!! $vlist" |
|
# append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] " |
|
# foreach vdef $o_variables { |
|
# append varDecls "[lindex $vdef 0] [lindex $vdef 0] " |
|
# } |
|
# append varDecls \n |
|
#} |
|
|
|
#runtime gathering of vars from other interfaces. |
|
#append varDecls [runtime_vardecls] |
|
|
|
set varDecls [runtime_vardecls] |
|
|
|
|
|
|
|
#implement methods |
|
|
|
#!todo - avoid globs on iface array? maintain list of methods in another slot? |
|
#foreach {n mname} [array get IFACE m-1,name,*] {} |
|
|
|
|
|
#namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. |
|
|
|
|
|
|
|
#implement property getters/setters/unsetters |
|
#'setter' overrides |
|
#pw short for propertywrite |
|
foreach {n property} [array get IFACE pw,name,*] { |
|
if {[string length $property]} { |
|
#set property [lindex [split $n ,] end] |
|
|
|
#!todo - next_script |
|
#set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] |
|
|
|
set maxversion [::p::predator::method_chainhead $IFID (SET)$property] |
|
set chainhead [expr {$maxversion + 1}] |
|
set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 |
|
|
|
set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? |
|
|
|
set body $IFACE(pw,body,$property) |
|
|
|
|
|
set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] |
|
if {[llength [dict get $processed varspaces_with_explicit_vars]]} { |
|
foreach vs [dict get $processed varspaces_with_explicit_vars] { |
|
if {[string length $vs] && ($vs ni $o_varspaces)} { |
|
lappend o_varspaces $vs |
|
} |
|
} |
|
set body [dict get $processed body] |
|
} else { |
|
set body $varDecls\n[dict get $processed body] |
|
#puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" |
|
} |
|
|
|
#set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] |
|
set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] |
|
|
|
|
|
|
|
set maxversion [::p::predator::method_chainhead $IFID $property] |
|
set headid [expr {$maxversion + 1}] |
|
|
|
proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body |
|
|
|
interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid |
|
|
|
#proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body |
|
} |
|
} |
|
#'unset' overrides |
|
|
|
dict for {property handler_info} $o_propertyunset_handlers { |
|
|
|
set body [dict get $handler_info body] |
|
set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array |
|
|
|
set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] |
|
set headid [expr {$maxversion + 1}] |
|
|
|
set THISNAME (UNSET)$property.$headid |
|
|
|
set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? |
|
|
|
|
|
|
|
|
|
|
|
set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] |
|
if {[llength [dict get $processed varspaces_with_explicit_vars]]} { |
|
foreach vs [dict get $processed varspaces_with_explicit_vars] { |
|
if {[string length $vs] && ($vs ni $o_varspaces)} { |
|
lappend o_varspaces $vs |
|
} |
|
} |
|
set body [dict get $processed body] |
|
} else { |
|
set body $varDecls\n[dict get $processed body] |
|
#puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body" |
|
|
|
} |
|
#set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] |
|
set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] |
|
|
|
|
|
|
|
|
|
#implement |
|
#always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) |
|
if {[string trim $arraykeypattern] eq ""} { |
|
set arraykeypattern "_dontcare_" |
|
} |
|
proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body |
|
|
|
|
|
#chainhead pointer |
|
interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid |
|
} |
|
|
|
|
|
|
|
interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) |
|
|
|
#the usual case will have no destructor - so use info exists to check. |
|
|
|
if {[info exists ::p::${IFID}::_iface::o_destructor_body]} { |
|
#!todo - chained destructors (support @next@). |
|
#set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID] |
|
set next NEXT |
|
|
|
set body [set ::p::${IFID}::_iface::o_destructor_body] |
|
|
|
|
|
set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] |
|
if {[llength [dict get $processed varspaces_with_explicit_vars]]} { |
|
foreach vs [dict get $processed varspaces_with_explicit_vars] { |
|
if {[string length $vs] && ($vs ni $o_varspaces)} { |
|
lappend o_varspaces $vs |
|
} |
|
} |
|
set body [dict get $processed body] |
|
} else { |
|
set body $varDecls\n[dict get $processed body] |
|
#puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body" |
|
} |
|
#set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body] |
|
#set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] |
|
set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] |
|
|
|
|
|
proc ::p::${IFID}::___system___destructor _ID_ $body |
|
} |
|
|
|
|
|
if {[info exists o_unknown]} { |
|
#use 'apply' somehow? |
|
interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown |
|
|
|
#namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] |
|
} |
|
|
|
|
|
return |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
#'info args' - assuming arbitrary chain of 'interp aliases' |
|
proc ::p::predator::command_info_args {cmd} { |
|
if {[llength [set next [interp alias {} $cmd]]]} { |
|
set curriedargs [lrange $next 1 end] |
|
|
|
if {[catch {set arglist [info args [lindex $next 0]]}]} { |
|
set arglist [command_info_args [lindex $next 0]] |
|
} |
|
#trim curriedargs |
|
return [lrange $arglist [llength $curriedargs] end] |
|
} else { |
|
info args $cmd |
|
} |
|
} |
|
|
|
|
|
proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { |
|
if {[llength $args]} { |
|
tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args |
|
} else { |
|
if {[llength $nextArgs] > 1} { |
|
set argVals [::list] |
|
set i 0 |
|
foreach arg [lrange $nextArgs 1 end] { |
|
upvar 1 $arg $i |
|
if {$arg eq "args"} { |
|
#need to check if 'args' is actually available in caller |
|
if {[info exists $i]} { |
|
set argVals [concat $argVals [set $i]] |
|
} |
|
} else { |
|
lappend argVals [set $i] |
|
} |
|
} |
|
tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals |
|
} else { |
|
tailcall ::p::${IFID}::_iface::$mname $_ID_ |
|
} |
|
} |
|
} |
|
|
|
#---------------------------------------------------------------------------------------------- |
|
proc ::p::predator::next_script {IFID method caller caller_ID_} { |
|
|
|
if {$caller eq "(CONSTRUCTOR).1"} { |
|
return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}] |
|
} elseif {$caller eq "$method.1"} { |
|
#delegate to next interface lower down the stack which has a member named $method |
|
return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] |
|
} elseif {[string match "(GET)*.2" $caller]} { |
|
# .1 is the getprop procedure, .2 is the bottom-most PropertyRead. |
|
|
|
#jmn |
|
set prop [string trimright $caller 1234567890] |
|
set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing . |
|
|
|
if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} { |
|
#return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}] |
|
return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] |
|
} else { |
|
#we can actually have a property read without a property or a method of that name - but it could also match the name of a method. |
|
# (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something) |
|
return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] |
|
} |
|
} elseif {[string match "(SET)*.2" $caller]} { |
|
return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] |
|
} else { |
|
#this branch will also handle (SET)*.x and (GET)*.x where x >2 |
|
|
|
#puts stdout "............next_script IFID:$IFID method:$method caller:$caller" |
|
set callerid [string range $caller [string length "$method."] end] |
|
set nextid [expr {$callerid - 1}] |
|
|
|
if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} { |
|
#not a proc directly on this interface - presumably an alias made by something like linkcopy_interface. |
|
#puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid" |
|
set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid] |
|
} |
|
|
|
return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] |
|
} |
|
} |
|
|
|
proc ::p::predator::do_next_if {_ID_ IFID method args} { |
|
#puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' (((" |
|
|
|
#set invocants [dict get $_ID_ i] |
|
#set this_invocantdata [lindex [dict get $invocants this] 0] |
|
#lassign $this_invocantdata OID this_info |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
set interfaces [dict get $MAP interfaces level0] |
|
set patterninterfaces [dict get $MAP interfaces level1] |
|
|
|
set L0_posn [lsearch $interfaces $IFID] |
|
if {$L0_posn == -1} { |
|
error "(::p::predator::do_next_if) called with interface not present at level0 for this object" |
|
} elseif {$L0_posn > 0} { |
|
#set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack |
|
set lower_interfaces [lrange $interfaces 0 $L0_posn-1] |
|
|
|
foreach if_sub [lreverse $lower_interfaces] { |
|
if {[string match "(GET)*" $method]} { |
|
#do not test o_properties here! We need to call even if there is no underlying property on this interface |
|
#(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) |
|
# relevant test: higher_order_propertyread_chaining |
|
return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] |
|
} elseif {[string match "(SET)*" $method]} { |
|
#must be called even if there is no matching $method in o_properties |
|
return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] |
|
} elseif {[string match "(UNSET)*" $method]} { |
|
#review untested |
|
#error "do_next_if (UNSET) untested" |
|
#puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'" |
|
return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] |
|
|
|
} elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} { |
|
if {[llength $args]} { |
|
#puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args" |
|
|
|
#return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] |
|
#tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args |
|
|
|
#!todo - handle case where llength $args is less than number of args for subinterface command |
|
#i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set) |
|
|
|
#handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature) |
|
set head [interp alias {} ::p::${if_sub}::_iface::$method] |
|
set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc |
|
set argx [list] |
|
foreach a $nextArgs { |
|
lappend argx "\$a" |
|
} |
|
|
|
#todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared |
|
|
|
if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} { |
|
tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args |
|
} else { |
|
#todo - upvars required for tail end of arglist |
|
tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args |
|
} |
|
|
|
} else { |
|
#auto-set: upvar vars from calling scope |
|
#!todo - robustify? alias not necessarily matching command name.. |
|
set head [interp alias {} ::p::${if_sub}::_iface::$method] |
|
|
|
|
|
set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc |
|
if {[llength $nextArgs] > 1} { |
|
set argVals [::list] |
|
set i 0 |
|
foreach arg [lrange $nextArgs 1 end] { |
|
upvar 1 $arg $i |
|
if {$arg eq "args"} { |
|
#need to check if 'args' is actually available in caller |
|
if {[info exists $i]} { |
|
set argVals [concat $argVals [set $i]] |
|
} |
|
} else { |
|
lappend argVals [set $i] |
|
} |
|
} |
|
#return [$head $_ID_ {*}$argVals] |
|
tailcall $head $_ID_ {*}$argVals |
|
} else { |
|
#return [$head $_ID_] |
|
tailcall $head $_ID_ |
|
} |
|
} |
|
} elseif {$method eq "(CONSTRUCTOR)"} { |
|
#chained constructors will only get args if the @next@ caller explicitly provided them. |
|
puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" |
|
#return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args] |
|
xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args |
|
} |
|
} |
|
#no interfaces in the iStack contained a matching method. |
|
return |
|
} else { |
|
#no further interfaces in this iStack |
|
return |
|
} |
|
} |
|
|
|
|
|
#only really makes sense for (CONSTRUCTOR) calls. |
|
#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class. |
|
proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { |
|
#puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" |
|
|
|
#set invocants [dict get $_ID_ i] |
|
#set this_invocant [lindex [dict get $invocants this] 0] |
|
#lassign $this_invocant OID this_info |
|
#set OID [lindex [dict get $invocants this] 0 0] |
|
#upvar #0 ::p::${OID}::_meta::map map |
|
#lassign [lindex $map 0] OID alias itemCmd cmd |
|
|
|
|
|
set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] |
|
upvar #0 ::p::${caller_OID}::_meta::map callermap |
|
|
|
#set interfaces [lindex $map 1 0] |
|
set patterninterfaces [dict get $callermap interfaces level1] |
|
|
|
set L0_posn [lsearch $patterninterfaces $IFID] |
|
if {$L0_posn == -1} { |
|
error "do_next_pattern_if called with interface not present at level1 for this object" |
|
} elseif {$L0_posn > 0} { |
|
|
|
|
|
set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] |
|
|
|
foreach if_sub [lreverse $lower_interfaces] { |
|
if {$method eq "(CONSTRUCTOR)"} { |
|
#chained constructors will only get args if the @next@ caller explicitly provided them. |
|
#puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" |
|
tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args |
|
} |
|
} |
|
#no interfaces in the iStack contained a matching method. |
|
return |
|
} else { |
|
#no further interfaces in this iStack |
|
return |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
|
|
#------------------------------------------------------------------------------------------------ |
|
|
|
|
|
|
|
|
|
|
|
#------------------------------------------------------------------------------------- |
|
####################################################### |
|
####################################################### |
|
####################################################### |
|
####################################################### |
|
####################################################### |
|
####################################################### |
|
####################################################### |
|
|
|
|
|
#!todo - can we just call new_object somehow to create this? |
|
|
|
#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://mini.net/tcl/1030 'Dangers of creative writing') |
|
namespace eval ::p::-1 { |
|
#namespace ensemble create |
|
|
|
namespace eval _ref {} |
|
namespace eval _meta {} |
|
|
|
namespace eval _iface { |
|
variable o_usedby |
|
variable o_open |
|
variable o_constructor |
|
variable o_variables |
|
variable o_properties |
|
variable o_methods |
|
variable o_definition |
|
variable o_varspace |
|
variable o_varspaces |
|
|
|
array set o_usedby [list i0 1] ;#!todo - review |
|
#'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? |
|
|
|
set o_open 1 |
|
set o_constructor [list] |
|
set o_variables [list] |
|
set o_properties [dict create] |
|
set o_methods [dict create] |
|
array set o_definition [list] |
|
set o_varspace "" |
|
set o_varspaces [list] |
|
} |
|
} |
|
|
|
|
|
# |
|
|
|
#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}] |
|
interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}] |
|
|
|
|
|
upvar #0 ::p::-1::_iface::o_definition def |
|
|
|
|
|
#! concatenate -> compose ?? |
|
dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}} |
|
proc ::p::-1::Concatenate {_ID_ target args} { |
|
set invocants [dict get $_ID_ i] |
|
#set invocant_alias [lindex [dict get $invocants this] 0] |
|
#set invocant [lindex [interp alias {} $invocant_alias] 1] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
|
|
if {![string match "::*" $target]} { |
|
if {[set ns [uplevel 1 {namespace current}]] eq "::"} { |
|
set target ::$target |
|
} else { |
|
set target ${ns}::$target |
|
} |
|
} |
|
#add > character if not already present |
|
set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] |
|
set _target [string map {::> ::} $target] |
|
|
|
set ns [namespace qualifiers $target] |
|
if {$ns eq ""} { |
|
set ns "::" |
|
} else { |
|
namespace eval $ns {} |
|
} |
|
|
|
if {![llength [info commands $target]]} { |
|
#degenerate case - target does not exist |
|
#Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone' |
|
#review - should be 'Copy' so it has object state from namespaces and variables? |
|
return [::p::-1::Clone $_ID_ $target {*}$args] |
|
|
|
#set TARGETMAP [::p::predator::new_object $target] |
|
#lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd |
|
|
|
} else { |
|
#set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] |
|
set TARGETMAP [$target --] |
|
|
|
lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd |
|
|
|
#Merge lastmodified(?) level0 and level1 interfaces. |
|
|
|
} |
|
|
|
return $target |
|
} |
|
|
|
|
|
|
|
#Object's Base-Interface proc with itself as curried invocant. |
|
#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant |
|
#namespace eval ::p::-1 {namespace export Create} |
|
dict set ::p::-1::_iface::o_methods Define {arglist definitions} |
|
#define objects in one step |
|
proc ::p::-1::Define {_ID_ definitions} { |
|
set invocants [dict get $_ID_ i] |
|
#set invocant_alias [lindex [dict get $invocants this] 0] |
|
#set invocant [lindex [interp alias {} $invocant_alias] 1] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
lassign [dict get $MAP invocantdata] OID alias default_method cmd |
|
set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces |
|
set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces |
|
|
|
#!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack |
|
#set IFID0 [lindex $interfaces 0] |
|
#set IFID1 [lindex $patterns 0] ;#1st pattern |
|
|
|
#set IFID_TOP [lindex $interfaces end] |
|
set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] |
|
|
|
#set ns ::p::${OID} |
|
|
|
#set script [string map [list %definitions% $definitions] { |
|
# if {[lindex [namespace path] 0] ne "::p::-1"} { |
|
# namespace path [list ::p::-1 {*}[namespace path]] |
|
# } |
|
# %definitions% |
|
# namespace path [lrange [namespace path] 1 end] |
|
# |
|
#}] |
|
|
|
set script [string map [list %id% $_ID_ %definitions% $definitions] { |
|
set ::p::-1::temp_unknown [namespace unknown] |
|
|
|
namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] |
|
|
|
|
|
#namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] |
|
|
|
|
|
%definitions% |
|
|
|
|
|
namespace unknown ${::p::-1::temp_unknown} |
|
return |
|
}] |
|
|
|
|
|
|
|
#uplevel 1 $script ;#this would run the script in the global namespace |
|
#run script in the namespace of the open interface, this allows creating of private helper procs |
|
#namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack |
|
#namespace inscope ::p::${OID} $script |
|
namespace eval ::p::${OID} $script |
|
#return $cmd |
|
} |
|
|
|
|
|
proc ::p::predator::redirect {func args} { |
|
|
|
#todo - review tailcall - tests? |
|
if {![llength [info commands ::p::-1::$func]]} { |
|
#error "invalid command name \"$func\"" |
|
tailcall uplevel 1 [list ::unknown $func {*}$args] |
|
} else { |
|
tailcall uplevel 1 [list ::p::-1::$func {*}$args] |
|
} |
|
} |
|
|
|
|
|
#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review. |
|
dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}} |
|
proc ::p::-1::Construct {_ID_ argpairs body args} { |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
|
|
set interfaces [dict get $MAP interfaces level0] |
|
set iid_top [lindex $interfaces end] |
|
namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace |
|
|
|
set ARGSETTER {} |
|
foreach {argname argval} $argpairs { |
|
append ARGSETTER "set $argname $argval\n" |
|
} |
|
#$_self (VIOLATE) $ARGSETTER$body |
|
|
|
set body $ARGSETTER\n$body |
|
|
|
|
|
set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] |
|
if {[llength [dict get $processed varspaces_with_explicit_vars]]} { |
|
foreach vs [dict get $processed varspaces_with_explicit_vars] { |
|
if {[string length $vs] && ($vs ni $o_varspaces)} { |
|
lappend o_varspaces $vs |
|
} |
|
} |
|
set body [dict get $processed body] |
|
} else { |
|
set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. |
|
set body $varDecls\n[dict get $processed body] |
|
# puts stderr "\t runtime_vardecls in Construct $varDecls" |
|
} |
|
|
|
set next "\[error {next not implemented}\]" |
|
#set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] |
|
set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] |
|
|
|
|
|
#namespace eval ::p::${iid_top} $body |
|
|
|
#return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] |
|
#does this handle Varspace before constructor? |
|
return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] |
|
} |
|
|
|
|
|
|
|
|
|
|
|
#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects |
|
namespace eval ::p::3 {} |
|
proc ::p::3::_create {child {OID "-2"}} { |
|
#puts stderr "::p::3::_create $child $OID" |
|
set _child [string map {::> ::} $child] |
|
if {$OID eq "-2"} { |
|
#set childmapdata [::p::internals::new_object $child] |
|
#set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] |
|
set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] |
|
upvar #0 ::p::${child_ID}::_meta::map CHILDMAP |
|
} else { |
|
set child_ID $OID |
|
#set _childmap [::p::internals::new_object $child "" $child_ID] |
|
::p::internals::new_object $child "" $child_ID |
|
upvar #0 ::p::${child_ID}::_meta::map CHILDMAP |
|
} |
|
|
|
#-------------- |
|
|
|
set oldinterfaces [dict get $CHILDMAP interfaces] |
|
dict set oldinterfaces level0 [list 2] |
|
set modifiedinterfaces $oldinterfaces |
|
dict set CHILDMAP interfaces $modifiedinterfaces |
|
|
|
#-------------- |
|
|
|
|
|
|
|
|
|
#puts stderr ">>>> creating alias for ::p::$child_ID" |
|
#puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" |
|
|
|
#interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! |
|
#interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] |
|
#puts stderr ">>>[interp alias {} ::p::$child_ID]" |
|
|
|
|
|
|
|
#--------------- |
|
namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties |
|
foreach method [dict keys $o_methods] { |
|
#todo - change from interp alias to context proc |
|
interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method |
|
} |
|
#namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] |
|
#implement property even if interface already compiled because we need to create defaults for each new child obj. |
|
# also need to add alias on base interface |
|
#make sure we are only implementing properties from the current CREATOR |
|
dict for {prop pdef} $o_properties { |
|
#lassign $pdef prop default |
|
interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop |
|
interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop |
|
|
|
} |
|
::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] |
|
#--------------- |
|
#namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" |
|
return $child |
|
} |
|
|
|
#configure -prop1 val1 -prop2 val2 ... |
|
dict set ::p::-1::_iface::o_methods Configure {arglist args} |
|
proc ::p::-1::Configure {_ID_ args} { |
|
|
|
#!todo - add tests. |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
|
|
lassign [dict get $MAP invocantdata] OID alias itemCmd this |
|
|
|
if {![expr {([llength $args] % 2) == 0}]} { |
|
error "expected even number of Configure args e.g '-property1 value1 -property2 value2'" |
|
} |
|
|
|
#Do a separate loop to check all the arguments before we run the property setting loop |
|
set properties_to_configure [list] |
|
foreach {argprop val} $args { |
|
if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} { |
|
error "expected Configure args in the form: '-property1 value1 -property2 value2'" |
|
} |
|
lappend properties_to_configure [string range $argprop 1 end] |
|
} |
|
|
|
#gather all valid property names for all level0 interfaces in the relevant interface stack |
|
set valid_property_names [list] |
|
set iflist [dict get $MAP interfaces level0] |
|
foreach id [lreverse $iflist] { |
|
set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]] |
|
foreach if_prop $interface_property_names { |
|
if {$if_prop ni $valid_property_names} { |
|
lappend valid_property_names $if_prop |
|
} |
|
} |
|
} |
|
|
|
foreach argprop $properties_to_configure { |
|
if {$argprop ni $valid_property_names} { |
|
error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names" |
|
} |
|
} |
|
|
|
set top_IID [lindex $iflist end] |
|
#args ok - go ahead and set all properties |
|
foreach {prop val} $args { |
|
set property [string range $prop 1 end] |
|
#------------ |
|
#don't use property ref unnecessarily - leaves property refs hanging around which traces need to update |
|
#ie don't do this here: set [$this . $property .] $val |
|
#------------- |
|
::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val] |
|
} |
|
return |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid} |
|
proc ::p::-1::AddPatternInterface {_ID_ iid} { |
|
#puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" |
|
if {![string is integer -strict $iid]} { |
|
error "adding interface by name not yet supported. Please use integer id" |
|
} |
|
|
|
set invocants [dict get $_ID_ i] |
|
#set invocant_alias [lindex [dict get $invocants this] 0] |
|
#set invocant [lindex [interp alias {} $invocant_alias] 1] |
|
#lassign [lindex $invocant 0] OID alias itemCmd cmd |
|
|
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces |
|
|
|
|
|
|
|
#it is theoretically possible to have the same interface present multiple times in an iStack. |
|
# #!todo -review why/whether this is useful. should we disallow it and treat as an error? |
|
|
|
lappend existing_ifaces $iid |
|
#lset map {1 1} $existing_ifaces |
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 $existing_ifaces |
|
dict set MAP interfaces $extracted_sub_dict |
|
|
|
#lset invocant {1 1} $existing_ifaces |
|
|
|
} |
|
|
|
|
|
#!todo - update usedby ?? |
|
dict set ::p::-1::_iface::o_methods AddInterface {arglist iid} |
|
proc ::p::-1::AddInterface {_ID_ iid} { |
|
#puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" |
|
if {![string is integer -strict $iid]} { |
|
error "adding interface by name not yet supported. Please use integer id" |
|
} |
|
|
|
|
|
lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. |
|
set this_invocant [lindex $list_of_invocants_for_role_this 0] |
|
|
|
lassign $this_invocant OID _etc |
|
|
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
set existing_ifaces [dict get $MAP interfaces level0] |
|
|
|
lappend existing_ifaces $iid |
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level0 $existing_ifaces |
|
dict set MAP interfaces $extracted_sub_dict |
|
return [dict get $extracted_sub_dict level0] |
|
} |
|
|
|
|
|
|
|
# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module. |
|
# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist |
|
# and 'CreateOverlay' for the case where the target/child object already exists. |
|
# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence, |
|
# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object. |
|
# 'CreateNew' will raise an error if the target already exists |
|
# 'CreateOverlay' will raise an error if the target object does not exist. |
|
# 'Create' will work in either case. Creating the target if necessary. |
|
|
|
|
|
#simple form: |
|
# >somepattern .. Create >child |
|
#simple form with arguments to the constructor: |
|
# >somepattern .. Create >child arg1 arg2 etc |
|
#complex form - specify more info about the target (dict keyed on childobject name): |
|
# >somepattern .. Create {>child {-id 1}} |
|
#or |
|
# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] |
|
#complex form - with arguments to the contructor: |
|
# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc |
|
dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}} |
|
proc ::p::-1::Create {_ID_ target_spec args} { |
|
#$args are passed to constructor |
|
if {[llength $target_spec] ==1} { |
|
set child $target_spec |
|
set targets [list $child {}] |
|
} else { |
|
set targets $target_spec |
|
} |
|
|
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
set invocants [dict get $_ID_ i] |
|
set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) |
|
|
|
foreach {child target_spec_dict} $targets { |
|
#puts ">>>::p::-1::Create $_ID_ $child $args <<<" |
|
|
|
|
|
|
|
#set invocant_alias [lindex [dict get $invocants this] 0] |
|
#set invocant [lindex [interp alias {} $invocant_alias] 1] |
|
|
|
|
|
|
|
|
|
#puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID" |
|
|
|
#child should already be fully ns qualified (?) |
|
#ensure it is has a pattern-object marker > |
|
#puts stderr ".... $child (nsqual: [namespace qualifiers $child])" |
|
|
|
|
|
lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd |
|
set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces |
|
set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces |
|
#puts "parent: $OID -> child:$child Patterns $patterns" |
|
|
|
#todo - change to dict of interface stacks |
|
set IFID0 [lindex $interfaces 0] |
|
set IFID1 [lindex $patterns 0] ;#1st pattern |
|
|
|
#upvar ::p::${OID}:: INFO |
|
|
|
if {![string match {::*} $child]} { |
|
if {[set ns [uplevel 1 {namespace current}]] eq "::"} { |
|
set child ::$child |
|
} else { |
|
set child ${ns}::$child |
|
} |
|
} |
|
|
|
|
|
#add > character if not already present |
|
set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >] |
|
set _child [string map {::> ::} $child] |
|
|
|
set ns [namespace qualifiers $child] |
|
if {$ns eq ""} { |
|
set ns "::" |
|
} else { |
|
namespace eval $ns {} |
|
} |
|
|
|
|
|
#maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls. |
|
set new_interfaces [list] |
|
|
|
if {![llength $patterns]} { |
|
##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child" |
|
#lappend patterns [::p::internals::new_interface $OID] |
|
|
|
#lset invocant {1 1} $patterns |
|
##update our command because we changed the interface list. |
|
#set IFID1 [lindex $patterns 0] |
|
|
|
#set patterns [list [::p::internals::new_interface $OID]] |
|
|
|
#set patterns [list [::p::internals::new_interface]] |
|
|
|
#set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id |
|
#set patterns [list [set iid [incr ::p::ID]]] |
|
set patterns [list [set iid [::p::get_new_object_id]]] |
|
|
|
#--------- |
|
#set iface [::p::>interface .. Create ::p::ifaces::>$iid] |
|
#::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid |
|
|
|
#lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation |
|
lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid] |
|
|
|
#--------- |
|
|
|
#puts "??> p::>interface .. Create ::p::ifaces::>$iid" |
|
#puts "??> [::p::ifaces::>$iid --]" |
|
#set [$iface . UsedBy .] |
|
} |
|
set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] |
|
|
|
#if {![llength [info commands $child]]} {} |
|
|
|
if {[namespace which $child] eq ""} { |
|
#normal case - target/child does not exist |
|
set is_new_object 1 |
|
|
|
if {[dict exists $target_spec_dict -id]} { |
|
set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]] |
|
} else { |
|
set childmapdata [::p::internals::new_object $child] |
|
} |
|
lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod |
|
upvar #0 ::p::${child_ID}::_meta::map CHILDMAP |
|
|
|
|
|
|
|
#child initially uses parent's level1 interface as it's level0 interface |
|
# child has no level1 interface until PatternMethods or PatternProperties are added |
|
# (or applied via clone; or via create with a parent with level2 interface) |
|
#set child_IFID $IFID1 |
|
|
|
#lset CHILDMAP {1 0} [list $IFID1] |
|
#lset CHILDMAP {1 0} $patterns |
|
|
|
set extracted_sub_dict [dict get $CHILDMAP interfaces] |
|
dict set extracted_sub_dict level0 $patterns |
|
dict set CHILDMAP interfaces $extracted_sub_dict |
|
|
|
#why write back when upvared??? |
|
#review |
|
set ::p::${child_ID}::_meta::map $CHILDMAP |
|
|
|
#::p::predator::remap $CHILDMAP |
|
|
|
#interp alias {} $child {} ::p::internals::predator $CHILDMAP |
|
|
|
#set child_IFID $IFID1 |
|
|
|
#upvar ::p::${child_ID}:: child_INFO |
|
|
|
#!todo review |
|
#set n ::p::${child_ID} |
|
#if {![info exists ${n}::-->PATTERN_ANCHOR]} { |
|
# #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" |
|
# #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack |
|
# set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" |
|
# trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] |
|
#} |
|
|
|
set ifaces_added $patterns |
|
|
|
} else { |
|
#overlay/mixin case - target/child already exists |
|
set is_new_object 0 |
|
|
|
#set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1] |
|
set childmapdata [$child --] |
|
|
|
|
|
#puts stderr " *** $cmd .. Create -> target $child already exists!!!" |
|
#puts " **** CHILDMAP: $CHILDMAP" |
|
#puts " ****" |
|
|
|
#puts stderr " ---> Properties: [$child .. Properties . names]" |
|
#puts stderr " ---> Methods: [$child .. Properties . names]" |
|
|
|
lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd |
|
upvar #0 ::p::${child_ID}::_meta::map CHILDMAP |
|
|
|
#set child_IFID [lindex $CHILDMAP 1 0 end] |
|
#if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} { |
|
# lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] |
|
# interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP |
|
#} |
|
##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces |
|
#::p::merge_interface $IFID1 $child_IFID |
|
|
|
|
|
set existing_interfaces [dict get $CHILDMAP interfaces level0] |
|
set ifaces_added [list] |
|
foreach p $patterns { |
|
if {$p ni $existing_interfaces} { |
|
lappend ifaces_added $p |
|
} |
|
} |
|
|
|
if {[llength $ifaces_added]} { |
|
#lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added] |
|
set extracted_sub_dict [dict get $CHILDMAP interfaces] |
|
dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added] |
|
dict set CHILDMAP interfaces $extracted_sub_dict |
|
#set ::p::${child_ID}::_meta::map $CHILDMAP ;#why? |
|
#::p::predator::remap $CHILDMAP |
|
} |
|
} |
|
|
|
#do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty |
|
if {$parent_patterndefaultmethod ne ""} { |
|
set child_defaultmethod $parent_patterndefaultmethod |
|
set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata] |
|
lset CHILD_INVOCANTDATA 2 $child_defaultmethod |
|
dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA |
|
#update the child's _ID_ |
|
interp alias {} $child_alias {} ;#first we must delete it |
|
interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}] |
|
|
|
#! object_command was initially created as the renamed alias - so we have to do it again |
|
rename $child_alias $child |
|
trace add command $child rename [list $child .. Rename] |
|
} |
|
#!todo - review - dont we already have interp alias entries for every method/prop? |
|
#namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" |
|
|
|
|
|
|
|
|
|
|
|
set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call. |
|
|
|
|
|
|
|
#------------------------------------------------------------------------------------ |
|
#create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail. |
|
# - All variables under the namespace - not just those declared as Variables or Properties |
|
# - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces. |
|
# - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write. |
|
|
|
#NOTE - do not use the objectID as the sole identifier for the snapshot namespace. |
|
# - there may be multiple active snapshots for a single object if it overlays itself during a constructor, |
|
# and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call. |
|
# - we will use an ever-increasing snapshotid to form part of ns_snap |
|
set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create. |
|
|
|
#!todo - this should look at child namespaces (recursively?) |
|
#!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces. |
|
# (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace) |
|
|
|
namespace eval $ns_snap {} |
|
foreach vname [info vars ::p::${child_ID}::*] { |
|
set shortname [namespace tail $vname] |
|
if {[array exists $vname]} { |
|
array set ${ns_snap}::${shortname} [array get $vname] |
|
} elseif {[info exists $vname]} { |
|
set ${ns_snap}::${shortname} [set $vname] |
|
} else { |
|
#variable exists without value (e.g created by 'variable' command) |
|
namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist' |
|
} |
|
} |
|
#------------------------------------------------------------------------------------ |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
#puts "====>>> ifaces_added $ifaces_added" |
|
set idx 0 |
|
set idx_count [llength $ifaces_added] |
|
set highest_constructor_IFID "" |
|
foreach IFID $ifaces_added { |
|
incr idx |
|
#puts "--> adding iface $IFID " |
|
namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces |
|
|
|
if {[llength $o_varspaces]} { |
|
foreach vs $o_varspaces { |
|
#ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work. |
|
if {[string match "::*" $vs]} { |
|
namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all. |
|
} else { |
|
namespace eval ::p::${child_ID}::$vs {} |
|
} |
|
} |
|
} |
|
|
|
if {$IFID != 2} { |
|
#>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list. |
|
if {![info exists o_usedby(i$child_ID)]} { |
|
set o_usedby(i$child_ID) $child_alias |
|
} |
|
|
|
#compile and close the interface only if it is shared |
|
if {$o_open} { |
|
::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_ |
|
set o_open 0 |
|
} |
|
} |
|
|
|
|
|
|
|
package require struct::set |
|
|
|
set propcmds [list] |
|
foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] { |
|
set cmd [namespace tail $cmd] |
|
#may contain multiple results for same prop e.g (GET)x.3 |
|
set cmd [string trimright $cmd 0123456789] |
|
set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals |
|
lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. |
|
} |
|
set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. |
|
#$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. |
|
foreach property $propcmds { |
|
#puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n" |
|
interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces |
|
interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property |
|
} |
|
|
|
set propcmds [list] |
|
foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] { |
|
set cmd [namespace tail $cmd] |
|
#may contain multiple results for same prop e.g (GET)x.3 |
|
set cmd [string trimright $cmd 0123456789] |
|
set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals |
|
lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. |
|
} |
|
set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. |
|
#$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. |
|
foreach property $propcmds { |
|
interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces |
|
} |
|
|
|
|
|
foreach method [dict keys $o_methods] { |
|
set arglist [dict get $o_methods $method arglist] |
|
set argvals "" |
|
foreach argspec $arglist { |
|
if {[llength $argspec] == 2} { |
|
set a [lindex $argspec 0] |
|
} else { |
|
set a $argspec |
|
} |
|
|
|
if {$a eq "args"} { |
|
append argvals " \{*\}\$args" |
|
} else { |
|
append argvals " \$$a" |
|
} |
|
} |
|
set argvals [string trimleft $argvals] |
|
|
|
#interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method |
|
|
|
#this proc directly on the object is not *just* a forwarding proc |
|
# - it provides a context in which the 'uplevel 1' from the running interface proc runs |
|
#This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) |
|
|
|
#proc calls the method in the interface - which is an interp alias to the head of the implementation chain |
|
|
|
|
|
proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst { |
|
::p::${IFID}::_iface::$method \$_ID_ $argvals |
|
}] |
|
|
|
#proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] { |
|
# ::p::@ID@::_iface::@m@ $_ID_ @argvals@ |
|
#}] |
|
|
|
|
|
} |
|
|
|
#namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] |
|
|
|
#implement property even if interface already compiled because we need to create defaults for each new child obj. |
|
# also need to add alias on base interface |
|
#make sure we are only implementing properties from the current CREATOR |
|
dict for {prop pdef} $o_properties { |
|
set varspace [dict get $pdef varspace] |
|
if {![string length $varspace]} { |
|
set ns ::p::${child_ID} |
|
} else { |
|
if {[string match "::*" $varspace]} { |
|
set ns $varspace |
|
} else { |
|
set ns ::p::${child_ID}::$varspace |
|
} |
|
} |
|
if {[dict exists $pdef default]} { |
|
if {![info exists ${ns}::o_$prop]} { |
|
#apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) |
|
set ${ns}::o_$prop [dict get $pdef default] |
|
} |
|
} |
|
#! May be replaced by a method with the same name |
|
if {$prop ni [dict keys $o_methods]} { |
|
interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop |
|
} |
|
interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop |
|
interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop |
|
} |
|
|
|
|
|
|
|
#variables |
|
#foreach vdef $o_variables { |
|
# if {[llength $vdef] == 2} { |
|
# #there is a default value defined. |
|
# lassign $vdef v default |
|
# if {![info exists ::p::${child_ID}::$v]} { |
|
# set ::p::${child_ID}::$v $default |
|
# } |
|
# } |
|
#} |
|
dict for {vname vdef} $o_variables { |
|
if {[dict exists $vdef default]} { |
|
#there is a default value defined. |
|
set varspace [dict get $vdef varspace] |
|
if {$varspace eq ""} { |
|
set ns ::p::${child_ID} |
|
} else { |
|
if {[string match "::*" $varspace]} { |
|
set ns $varspace |
|
} else { |
|
set ns ::p::${child_ID}::$varspace |
|
} |
|
} |
|
set ${ns}::$vname [dict get $vdef default] |
|
} |
|
} |
|
|
|
|
|
#!todo - review. Write tests for cases of multiple constructors! |
|
|
|
#We don't want to the run constructor for each added interface with the same set of args! |
|
#run for last one - rely on constructor authors to use @next@ properly? |
|
if {[llength [set ::p::${IFID}::_iface::o_constructor]]} { |
|
set highest_constructor_IFID $IFID |
|
} |
|
|
|
if {$idx == $idx_count} { |
|
#we are processing the last interface that was added - now run the latest constructor found |
|
if {$highest_constructor_IFID ne ""} { |
|
#at least one interface has a constructor |
|
if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} { |
|
#puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP" |
|
if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} { |
|
set constructor_failure 1 |
|
set constructor_errorInfo $::errorInfo ;#cache it immediately. |
|
break |
|
} |
|
} |
|
} |
|
} |
|
|
|
if {[info exists o_unknown]} { |
|
interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown |
|
interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown |
|
|
|
|
|
#interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown |
|
#namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] |
|
#namespace eval ::p::${child_ID} [list namespace unknown $o_unknown] |
|
} |
|
} |
|
|
|
if {$constructor_failure} { |
|
if {$is_new_object} { |
|
#is Destroy enough to ensure that no new interfaces or objects were left dangling? |
|
$child .. Destroy |
|
} else { |
|
#object needs to be returned to a sensible state.. |
|
#attempt to rollback all interface additions and object state changes! |
|
puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n" |
|
#remove variables from the object's namespace - which don't exist in the snapshot. |
|
set snap_vars [info vars ${ns_snap}::*] |
|
puts "ns_snap '$ns_snap' vars'${snap_vars}'" |
|
foreach vname [info vars ::p::${child_ID}::*] { |
|
set shortname [namespace tail $vname] |
|
if {"${ns_snap}::$shortname" ni "$snap_vars"} { |
|
#puts "--- >>>>> unsetting $shortname " |
|
unset -nocomplain $vname |
|
} |
|
} |
|
|
|
#restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces) |
|
#values of vars may also have Changed |
|
#todo - consider traces? what is the correct behaviour? |
|
# - some application traces may have fired before the constructor error occurred. |
|
# Should the rollback now also trigger traces? |
|
#probably yes. |
|
|
|
#we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value |
|
foreach vname $snap_vars { |
|
#puts stdout "@@@@@@@@@@@ restoring $vname" |
|
#flush stdout |
|
|
|
|
|
set shortname [namespace tail $vname] |
|
set target ::p::${child_ID}::$shortname |
|
if {$target in [info vars ::p::${child_ID}::*]} { |
|
set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only' |
|
} else { |
|
set present 0 |
|
} |
|
|
|
if {[array exists $vname]} { |
|
#restore 'array' variable |
|
if {!$present} { |
|
array set $target [array get $vname] |
|
} else { |
|
if {[array exists $target]} { |
|
#unset superfluous elements |
|
foreach key [array names $target] { |
|
if {$key ni [array names $vname]} { |
|
array unset $target $key |
|
} |
|
} |
|
#.. and write only elements that have changed. |
|
foreach key [array names $vname] { |
|
if {[set ${target}($key)] ne [set ${vname}($key)]} { |
|
set ${target}($key) [set ${vname}($key)] |
|
} |
|
} |
|
} else { |
|
#target has been changed to a simple variable - unset it and recreate the array. |
|
unset $target |
|
array set $target [array get $vname] |
|
} |
|
} |
|
} elseif {[info exists $vname]} { |
|
#restore 'simple' variable |
|
if {!$present} { |
|
set $target [set $vname] |
|
} else { |
|
if {[array exists $target]} { |
|
#target has been changed to array - unset it and recreate the simple variable. |
|
unset $target |
|
set $target [set $vname] |
|
} else { |
|
if {[set $target] ne [set $vname]} { |
|
set $target [set $vname] |
|
} |
|
} |
|
} |
|
} else { |
|
#restore 'declared' variable |
|
if {[array exists $target] || [info exists $target]} { |
|
unset -nocomplain $target |
|
} |
|
namespace eval ::p::${child_ID} [list variable $shortname] |
|
} |
|
} |
|
} |
|
namespace delete $ns_snap |
|
return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error |
|
} |
|
namespace delete $ns_snap |
|
|
|
} |
|
|
|
|
|
|
|
return $child |
|
} |
|
|
|
dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} |
|
#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied* |
|
# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*) |
|
# Also: Any 'open' interfaces on the parent become closed on clone! |
|
proc ::p::-1::Clone {_ID_ clone args} { |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
|
|
set invocants [dict get $_ID_ i] |
|
lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd |
|
|
|
set _cmd [string map {::> ::} $cmd] |
|
set tail [namespace tail $_cmd] |
|
|
|
|
|
#obsolete? |
|
##set IFID0 [lindex $map 1 0 end] |
|
#set IFID0 [lindex [dict get $MAP interfaces level0] end] |
|
##set IFID1 [lindex $map 1 1 end] |
|
#set IFID1 [lindex [dict get $MAP interfaces level1] end] |
|
|
|
|
|
if {![string match "::*" $clone]} { |
|
if {[set ns [uplevel 1 {namespace current}]] eq "::"} { |
|
set clone ::$clone |
|
} else { |
|
set clone ${ns}::$clone |
|
} |
|
} |
|
|
|
|
|
set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] |
|
set _clone [string map {::> ::} $clone] |
|
|
|
|
|
set cTail [namespace tail $_clone] |
|
|
|
set ns [namespace qualifiers $clone] |
|
if {$ns eq ""} { |
|
set ns "::" |
|
} |
|
|
|
namespace eval $ns {} |
|
|
|
|
|
#if {![llength [info commands $clone]]} {} |
|
if {[namespace which $clone] eq ""} { |
|
set clonemapdata [::p::internals::new_object $clone] |
|
} else { |
|
#overlay/mixin case - target/clone already exists |
|
#set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1] |
|
set clonemapdata [$clone --] |
|
} |
|
set clone_ID [lindex [dict get $clonemapdata invocantdata] 0] |
|
|
|
upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP |
|
|
|
|
|
#copy patterndata element of MAP straight across |
|
dict set CLONEMAP patterndata [dict get $MAP patterndata] |
|
set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata] |
|
lset CLONE_INVOCANTDATA 2 $parent_defaultmethod |
|
dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA |
|
lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone |
|
|
|
#update the clone's _ID_ |
|
interp alias {} $clone_alias {} ;#first we must delete it |
|
interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}] |
|
|
|
#! object_command was initially created as the renamed alias - so we have to do it again |
|
rename $clone_alias $clone |
|
trace add command $clone rename [list $clone .. Rename] |
|
|
|
|
|
|
|
|
|
#obsolete? |
|
#upvar ::p::${clone_ID}:: clone_INFO |
|
#upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. |
|
#upvar ::p::${OID}:: INFO |
|
|
|
|
|
array set clone_INFO [array get INFO] |
|
|
|
array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' |
|
|
|
|
|
#!review! |
|
#if {![catch {set itemCmd $IFACE(m-1,name,item)}]} { |
|
#puts "***************" |
|
#puts "clone" |
|
#parray IFINFO |
|
#puts "***************" |
|
#} |
|
|
|
#we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern |
|
|
|
|
|
#clone's interface maps must be a superset of original's |
|
foreach lev {0 1} { |
|
#set parent_ifaces [lindex $map 1 $lev] |
|
set parent_ifaces [dict get $MAP interfaces level$lev] |
|
|
|
#set existing_ifaces [lindex $CLONEMAP 1 $lev] |
|
set existing_ifaces [dict get $CLONEMAP interfaces level$lev] |
|
|
|
set added_ifaces_$lev [list] |
|
foreach ifid $parent_ifaces { |
|
if {$ifid ni $existing_ifaces} { |
|
|
|
#interface must not remain extensible after cloning. |
|
if {[set ::p::${ifid}::_iface::o_open]} { |
|
::p::predator::compile_interface $ifid $_ID_ |
|
set ::p::${ifid}::_iface::o_open 0 |
|
} |
|
|
|
|
|
|
|
lappend added_ifaces_$lev $ifid |
|
#clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. |
|
set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone |
|
} |
|
} |
|
set extracted_sub_dict [dict get $CLONEMAP interfaces] |
|
dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]] |
|
dict set CLONEMAP interfaces $extracted_sub_dict |
|
#lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]] |
|
} |
|
|
|
#interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE) |
|
|
|
|
|
#foreach *added* level0 interface.. |
|
foreach ifid $added_ifaces_0 { |
|
namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown |
|
|
|
|
|
dict for {prop pdef} $o_properties { |
|
#lassign $pdef prop default |
|
if {[dict exists $pdef default]} { |
|
set varspace [dict get $pdef varspace] |
|
if {$varspace eq ""} { |
|
set ns ::p::${clone_ID} |
|
} else { |
|
if {[string match "::*" $varspace]} { |
|
set ns $varspace |
|
} else { |
|
set ns ::p::${clone_ID}::$varspace |
|
} |
|
} |
|
|
|
if {![info exists ${ns}::o_$prop]} { |
|
#apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) |
|
set ${ns}::o_$prop [dict get $pdef default] |
|
} |
|
} |
|
|
|
#! May be replaced by method of same name |
|
if {[namespace which ::p::${clone_ID}::$prop] eq ""} { |
|
interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop |
|
} |
|
interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop |
|
interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop |
|
} |
|
|
|
#variables |
|
dict for {vname vdef} $o_variables { |
|
if {[dict exists $vdef default]} { |
|
set varspace [dict get $vdef varspace] |
|
if {$varspace eq ""} { |
|
set ns ::p::${clone_ID} |
|
} else { |
|
if {[string match "::*" $varspace]} { |
|
set ns $varspace |
|
} else { |
|
set ns ::p::${clone_ID}::$varspace |
|
} |
|
} |
|
if {![info exists ${ns}::$vname]} { |
|
set ::p::${clone_ID}::$vname [dict get $vdef default] |
|
} |
|
} |
|
} |
|
|
|
|
|
#update the clone object's base interface to reflect the new methods. |
|
#upvar 0 ::p::${ifid}:: IFACE |
|
#set methods [list] |
|
#foreach {key mname} [array get IFACE m-1,name,*] { |
|
# set method [lindex [split $key ,] end] |
|
# interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP |
|
# lappend methods $method |
|
#} |
|
#namespace eval ::p::${clone_ID} [list namespace export {*}$methods] |
|
|
|
|
|
foreach method [dict keys $o_methods] { |
|
|
|
set arglist [dict get $o_methods $method arglist] |
|
set argvals "" |
|
foreach argspec $arglist { |
|
if {[llength $argspec] == 2} { |
|
set a [lindex $argspec 0] |
|
} else { |
|
set a $argspec |
|
} |
|
|
|
if {$a eq "args"} { |
|
append argvals " \{*\}\$args" |
|
} else { |
|
append argvals " \$$a" |
|
} |
|
} |
|
set argvals [string trimleft $argvals] |
|
#interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method |
|
|
|
|
|
#this proc directly on the object is not *just* a forwarding proc |
|
# - it provides a context in which the 'uplevel 1' from the running interface proc runs |
|
#This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) |
|
|
|
#proc calls the method in the interface - which is an interp alias to the head of the implementation chain |
|
proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst { |
|
::p::${ifid}::_iface::$method \$_ID_ $argvals |
|
}] |
|
|
|
} |
|
#namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods] |
|
|
|
|
|
if {[info exists o_unknown]} { |
|
#interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown |
|
interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown |
|
interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown |
|
|
|
#namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown] |
|
#namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown] |
|
|
|
} |
|
|
|
|
|
#2021 |
|
#Consider >parent with constructor that sets height |
|
#.eg >parent .. Constructor height { |
|
# set o_height $height |
|
#} |
|
#>parent .. Create >child 5 |
|
# - >child has height 5 |
|
# now when we peform a clone operation - it is the >parent's constructor that will run. |
|
# A clone will get default property and var values - but not other variable values unless the constructor sets them. |
|
#>child .. Clone >fakesibling 6 |
|
# - >sibling has height 6 |
|
# Consider if >child had it's own constructor created with .. Construct prior to the clone operation. |
|
# The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead. |
|
# If we now add a constructor to >fakesibling - and put @next@ for constructor chaining... |
|
# when we now do >sibling .. Create >grandchild |
|
# - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild |
|
# (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.) |
|
# However - the args supplied in the >clone operation don't get either constructor running on the >grandchild |
|
#(though other arguments can be manually passed) |
|
# #!review - does this make sense? What if we add |
|
# |
|
#constructor for each interface called after properties initialised. |
|
#run each interface's constructor against child object, using the args passed into this clone method. |
|
if {[llength [set constructordef [set o_constructor]]]} { |
|
#error |
|
puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID" |
|
::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args |
|
|
|
} |
|
|
|
} |
|
|
|
|
|
return $clone |
|
|
|
} |
|
|
|
|
|
|
|
interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?) |
|
dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}} |
|
proc ::p::-1::Constructor {_ID_ arglist body} { |
|
set invocants [dict get $_ID_ i] |
|
#set invocant_alias [lindex [dict get $invocants this] 0] |
|
#set invocant [lindex [interp alias {} $invocant_alias] 1] |
|
#lassign [lindex $invocant 0 ] OID alias itemCmd cmd |
|
|
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
set patterns [dict get $MAP interfaces level1] |
|
set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. |
|
set iface ::p::ifaces::>$iid_top |
|
|
|
if {(![string length $iid_top]) || ([$iface . isClosed])} { |
|
#no existing pattern - create a new interface |
|
set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id |
|
#set iid_top [::p::get_new_object_id] |
|
|
|
#the >interface constructor takes a list of IDs for o_usedby |
|
set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 [concat $patterns $iid_top] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 1} [concat $patterns $iid_top] |
|
|
|
#::p::predator::remap $invocant |
|
} |
|
set IID $iid_top |
|
|
|
namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces |
|
|
|
|
|
# examine the existing command-chain |
|
set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] |
|
set headid [expr {$maxversion + 1}] |
|
set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 |
|
|
|
set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] |
|
|
|
#set varspaces [::pattern::varspace_list] |
|
set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] |
|
|
|
if {[llength [dict get $processed varspaces_with_explicit_vars]]} { |
|
foreach vs [dict get $processed varspaces_with_explicit_vars] { |
|
if {[string length $vs] && ($vs ni $o_varspaces)} { |
|
lappend o_varspaces $vs |
|
} |
|
} |
|
set body [dict get $processed body] |
|
} else { |
|
set varDecls [::p::predator::runtime_vardecls] |
|
set body $varDecls\n[dict get $processed body] |
|
#puts stderr "\t runtime_vardecls in Constructor $varDecls" |
|
} |
|
|
|
#set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] |
|
set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] |
|
|
|
#puts stderr ---- |
|
#puts stderr $body |
|
#puts stderr ---- |
|
|
|
proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body |
|
interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid |
|
|
|
|
|
|
|
set o_constructor [list $arglist $body] |
|
set o_open 1 |
|
|
|
return |
|
} |
|
|
|
|
|
|
|
dict set ::p::-1::_iface::o_methods UsedBy {arglist {}} |
|
proc ::p::-1::UsedBy {_ID_} { |
|
return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby] |
|
} |
|
|
|
|
|
dict set ::p::-1::_iface::o_methods Ready {arglist {}} |
|
proc ::p::-1::Ready {_ID_} { |
|
return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}] |
|
} |
|
|
|
|
|
|
|
dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}} |
|
|
|
#'force' 1 indicates object command & variable will also be removed. |
|
#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var. |
|
#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4) |
|
# |
|
proc ::p::-1::Destroy {_ID_ {force 1}} { |
|
#puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]" |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
|
|
if {$OID eq "null"} { |
|
puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" |
|
return |
|
} |
|
|
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
|
|
|
|
#puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout |
|
|
|
#explicit Destroy - remove traces |
|
#puts ">>TRACES: [trace info variable $cmd]" |
|
#foreach tinfo [trace info variable $cmd] { |
|
# trace remove variable $cmd {*}$tinfo |
|
#} |
|
#foreach tinfo [trace info command $cmd] { |
|
# trace remove command $cmd {*}$tinfo |
|
#} |
|
|
|
|
|
set _cmd [string map {::> ::} $cmd] |
|
|
|
#set ifaces [lindex $map 1] |
|
set iface_stacks [dict get $MAP interfaces level0] |
|
#set patterns [lindex $map 2] |
|
set pattern_stacks [dict get $MAP interfaces level1] |
|
|
|
|
|
|
|
set ifaces $iface_stacks |
|
|
|
|
|
set patterns $pattern_stacks |
|
|
|
|
|
#set i 0 |
|
#foreach iflist $ifaces { |
|
# set IFID$i [lindex $iflist 0] |
|
# incr i |
|
#} |
|
|
|
|
|
set IFTOP [lindex $ifaces end] |
|
|
|
set DESTRUCTOR ::p::${IFTOP}::___system___destructor |
|
#may be a proc, or may be an alias |
|
if {[namespace which $DESTRUCTOR] ne ""} { |
|
set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] |
|
|
|
if {[catch {$DESTRUCTOR $temp_ID_} prob]} { |
|
#!todo - ensure correct calling order of interfaces referencing the destructor proc |
|
|
|
|
|
#!todo - emit destructor errors somewhere - logger? |
|
#puts stderr "underlying proc already removed??? ---> $prob" |
|
#puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" |
|
#puts stderr $::errorInfo |
|
#puts stderr "---------------------" |
|
} |
|
} |
|
|
|
|
|
#remove ourself from each interfaces list of referencers |
|
#puts stderr "--- $ifaces" |
|
|
|
foreach var {ifaces patterns} { |
|
|
|
foreach i [set $var] { |
|
|
|
if {[string length $i]} { |
|
if {$i == 2} { |
|
#skip the >ifinfo interface which doesn't maintain a usedby list anyway. |
|
continue |
|
} |
|
|
|
if {[catch { |
|
|
|
upvar #0 ::p::${i}::_iface::o_usedby usedby |
|
|
|
array unset usedby i$OID |
|
|
|
|
|
#puts "\n***>>***" |
|
#puts "IFACE: $i usedby: $usedby" |
|
#puts "***>>***\n" |
|
|
|
#remove interface if no more referencers |
|
if {![array size usedby]} { |
|
#puts " **************** DESTROYING unused interface $i *****" |
|
#catch {namespace delete ::p::$i} |
|
|
|
#we happen to know where 'interface' object commands are kept: |
|
|
|
::p::ifaces::>$i .. Destroy |
|
|
|
} |
|
|
|
} errMsg]} { |
|
#warning |
|
puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" |
|
} |
|
} |
|
|
|
} |
|
|
|
} |
|
|
|
set ns ::p::${OID} |
|
#puts "-- destroying objects below namespace:'$ns'" |
|
::p::internals::DestroyObjectsBelowNamespace $ns |
|
#puts "--.destroyed objects below '$ns'" |
|
|
|
|
|
#set ns ::p::${OID}::_sub |
|
#call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace |
|
#( ::p::OBJECT::$OID ) |
|
#puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" |
|
#::p::internals::DestroyObjectsBelowNamespace $ns |
|
|
|
#same for _meta objects (e.g Methods,Properties collections) |
|
#set ns ::p::${OID}::_meta |
|
#::p::internals::DestroyObjectsBelowNamespace $ns |
|
|
|
|
|
|
|
#foreach obj [info commands ${ns}::>*] { |
|
# #Assume it's one of ours, and ask it to die. |
|
# catch {::p::meta::Destroy $obj} |
|
# #catch {$cmd .. Destroy} |
|
#} |
|
#just in case the user created subnamespaces.. kill objects there too. |
|
#foreach sub [namespace children $ns] { |
|
# ::p::internals::DestroyObjectsBelowNamespace $sub |
|
#} |
|
|
|
|
|
#!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value! |
|
#use info commands ::p::${OID}::_ref::* to find all references - including variables never set |
|
#remove variable traces on REF vars |
|
#foreach rv [info vars ::p::${OID}::_ref::*] { |
|
# foreach tinfo [trace info variable $rv] { |
|
# #puts "-->removing traces on $rv: $tinfo" |
|
# trace remove variable $rv {*}$tinfo |
|
# } |
|
#} |
|
|
|
#!todo - write tests |
|
#refs create aliases and variables at the same place |
|
#- but variable may not exist if it was never set e.g if it was only used with info exists |
|
foreach rv [info commands ::p::${OID}::_ref::*] { |
|
foreach tinfo [trace info variable $rv] { |
|
#puts "-->removing traces on $rv: $tinfo" |
|
trace remove variable $rv {*}$tinfo |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
#if {[catch {namespace delete $nsMeta} msg]} { |
|
# puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " |
|
#} else { |
|
# #puts stderr "------ -- -- -- -- deleted $nsMeta " |
|
#} |
|
|
|
|
|
#!todo - remove |
|
#temp |
|
#catch {interp alias "" ::>$OID ""} |
|
|
|
if {$force} { |
|
#rename $cmd {} |
|
|
|
#removing the alias will remove the command - even if it's been renamed |
|
interp alias {} $alias {} |
|
|
|
#if {[catch {rename $_cmd {} } why]} { |
|
# #!todo - work out why some objects don't have matching command. |
|
# #puts stderr "\t rename $_cmd {} failed" |
|
#} else { |
|
# puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" |
|
#} |
|
|
|
} |
|
|
|
set refns ::p::${OID}::_ref |
|
#puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" |
|
#puts "- children: [llength [namespace children $refns]]" |
|
#puts "- vars : [llength [info vars ${refns}::*]]" |
|
#puts "- commands: [llength [info commands ${refns}::*]]" |
|
#puts "- procs : [llength [info procs ${refns}::*]]" |
|
#puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" |
|
#puts "- matching command: [llength [info commands ${refns}]]" |
|
#puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" |
|
|
|
|
|
#foreach v [info vars ${refns}::*] { |
|
# unset $v |
|
#} |
|
#foreach p [info procs ${refns}::*] { |
|
# rename $p {} |
|
#} |
|
#foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { |
|
# interp alias {} $a {} |
|
#} |
|
|
|
|
|
#set ts1 [clock seconds] |
|
#puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." |
|
#puts "- children: [llength [namespace children $refns]]" |
|
#puts "- vars : [llength [info vars ${refns}::*]]" |
|
|
|
#puts "- commands: [llength [info commands ${refns}::*]]" |
|
#puts "- procs : [llength [info procs ${refns}::*]]" |
|
#puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" |
|
#puts "- exact command: [info commands ${refns}]" |
|
|
|
|
|
|
|
|
|
#puts "--delete ::p::${OID}::_ref" |
|
if {[namespace exists ::p::${OID}::_ref]} { |
|
#could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. |
|
namespace delete ::p::${OID}::_ref:: |
|
} |
|
set ts2 [clock seconds] |
|
#puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" |
|
|
|
|
|
#delete namespace where instance variables reside |
|
#catch {namespace delete ::p::$OID} |
|
namespace delete ::p::$OID |
|
|
|
#puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout |
|
return |
|
} |
|
|
|
|
|
interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility |
|
|
|
|
|
dict set ::p::-1::_iface::o_methods Destructor {arglist {args}} |
|
#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction? |
|
#install a Destructor on the invocant's open level1 interface. |
|
proc ::p::-1::Destructor {_ID_ args} { |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
|
|
#lassign [lindex $map 0] OID alias itemCmd cmd |
|
|
|
set patterns [dict get $MAP interfaces level1] |
|
|
|
if {[llength $args] > 2} { |
|
error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" |
|
} |
|
|
|
set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. |
|
|
|
if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { |
|
array unset ::p::${existing_IID}::_iface::o_usedby i$OID |
|
error "NOT TESTED" |
|
set ::p::${IID}::_iface::o_usedby(i$OID) $cmd |
|
|
|
set posn [lsearch $patterns $existing_IID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] |
|
|
|
#::p::predator::remap $invocant |
|
} |
|
|
|
|
|
set ::p::${IID}::_iface::o_destructor_body [lindex $args end] |
|
|
|
if {[llength $args] > 1} { |
|
#!todo - allow destructor args(?) |
|
set arglist [lindex $args 0] |
|
} else { |
|
set arglist [list] |
|
} |
|
|
|
set ::p::${IID}::_iface::o_destructor_args $arglist |
|
|
|
return |
|
} |
|
|
|
|
|
|
|
|
|
|
|
interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit) |
|
|
|
|
|
dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}} |
|
proc ::p::-1::PatternMethod {_ID_ method arglist body} { |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped |
|
|
|
set patterns [dict get $MAP interfaces level1] |
|
set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. |
|
set iface ::p::ifaces::>$iid_top |
|
|
|
if {(![string length $iid_top]) || ([$iface . isClosed])} { |
|
#no existing pattern - create a new interface |
|
set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id |
|
set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] |
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 [concat $patterns $iid_top] |
|
dict set MAP interfaces $extracted_sub_dict |
|
} |
|
set IID $iid_top |
|
|
|
|
|
namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces |
|
|
|
|
|
# examine the existing command-chain |
|
set maxversion [::p::predator::method_chainhead $IID $method] |
|
set headid [expr {$maxversion + 1}] |
|
set THISNAME $method.$headid ;#first version will be $method.1 |
|
|
|
set next [::p::predator::next_script $IID $method $THISNAME $_ID_] |
|
|
|
|
|
set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] |
|
if {[llength [dict get $processed varspaces_with_explicit_vars]]} { |
|
foreach vs [dict get $processed varspaces_with_explicit_vars] { |
|
if {[string length $vs] && ($vs ni $o_varspaces)} { |
|
lappend o_varspaces $vs |
|
} |
|
} |
|
set body [dict get $processed body] |
|
} else { |
|
set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. |
|
#puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls" |
|
set body $varDecls\n[dict get $processed body] |
|
#puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls" |
|
} |
|
|
|
|
|
set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist] |
|
|
|
#set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] |
|
set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] |
|
#puts "\t\t--------------------" |
|
#puts "\n" |
|
#puts $body |
|
#puts "\n" |
|
#puts "\t\t--------------------" |
|
proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body |
|
|
|
|
|
|
|
#pointer from method-name to head of the interface's command-chain |
|
interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME |
|
|
|
|
|
|
|
if {$method in [dict keys $o_methods]} { |
|
#error "patternmethod '$method' already present in interface $IID" |
|
set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)" |
|
if {[string match "*@next@*" $body]} { |
|
append msg "\n EXTRA-WARNING: method contains @next@" |
|
} |
|
|
|
puts stdout $msg |
|
} else { |
|
dict set o_methods $method [list arglist $arglist] |
|
} |
|
|
|
#::p::-1::update_invocant_aliases $_ID_ |
|
return |
|
} |
|
|
|
#MultiMethod |
|
#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants |
|
# e.g1 $obj .. MultiMethod add {these 2} $arglist $body |
|
# e.g2 $obj .. MultiMethod add {these n} $arglist $body |
|
# |
|
# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body |
|
# |
|
# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature. |
|
# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature) |
|
# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces) |
|
# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? |
|
# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed? |
|
# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? |
|
# (and how would we define the call order? - presumably as it appears in the conglomerate) |
|
# (or could that be done with a more general method-wrapping mechanism?) |
|
#...should multimethods use some sort of event mechanism, and/or message-passing system? |
|
# |
|
dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}} |
|
proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { |
|
set invocants [dict get $_ID_ i] |
|
|
|
error "not implemented" |
|
} |
|
|
|
dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} |
|
# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- ) |
|
#we can create a method named "." by using the argprotect operator -- |
|
# e.g >x .. Method -- . {args} $body |
|
#It can then be called like so: >x . . |
|
#This is not guaranteed to work and is not in the test suite |
|
#for now we'll just use a highly unlikely string to indicate no argument was supplied |
|
proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { |
|
set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped |
|
if {$methodname eq $non_argument_magicstring} { |
|
return $default_method |
|
} else { |
|
set extracted_value [dict get $MAP invocantdata] |
|
lset extracted_value 2 $methodname |
|
dict set MAP invocantdata $extracted_value ;#write modified value back |
|
#update the object's command alias to match |
|
interp alias {} $alias {} ;#first we must delete it |
|
interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] |
|
|
|
#! $object_command was initially created as the renamed alias - so we have to do it again |
|
rename $alias $object_command |
|
trace add command $object_command rename [list $object_command .. Rename] |
|
return $methodname |
|
} |
|
} |
|
|
|
dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} |
|
proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { |
|
set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
set extracted_patterndata [dict get $MAP patterndata] |
|
set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] |
|
if {$methodname eq $non_argument_magicstring} { |
|
return $pattern_default_method |
|
} else { |
|
dict set extracted_patterndata patterndefaultmethod $methodname |
|
dict set MAP patterndata $extracted_patterndata |
|
return $methodname |
|
} |
|
} |
|
|
|
|
|
dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}} |
|
proc ::p::-1::Method {_ID_ method arglist bodydef args} { |
|
set invocants [dict get $_ID_ i] |
|
|
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
|
|
set invocant_signature [list] ; |
|
;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. |
|
foreach role [lsort [dict keys $invocants]] { |
|
lappend invocant_signature $role [llength [dict get $invocants $role]] |
|
} |
|
#note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this') |
|
|
|
|
|
|
|
lassign [dict get $MAP invocantdata] OID alias default_method object_command |
|
set interfaces [dict get $MAP interfaces level0] |
|
|
|
|
|
|
|
################################################################################# |
|
if 0 { |
|
set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface |
|
set prev_open [set ::p::${iid_top}::_iface::o_open] |
|
|
|
set iface ::p::ifaces::>$iid_top |
|
|
|
set f_new 0 |
|
if {![string length $iid_top]} { |
|
set f_new 1 |
|
} else { |
|
if {[$iface . isClosed]} { |
|
set f_new 1 |
|
} |
|
} |
|
if {$f_new} { |
|
#create a new interface |
|
set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id |
|
set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level0 [concat $interfaces $iid_top] |
|
dict set MAP interfaces $extracted_sub_dict |
|
|
|
} |
|
set IID $iid_top |
|
|
|
} |
|
################################################################################# |
|
|
|
set IID [::p::predator::get_possibly_new_open_interface $OID] |
|
|
|
#upvar 0 ::p::${IID}:: IFACE |
|
|
|
namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces |
|
|
|
|
|
#Interface proc |
|
# examine the existing command-chain |
|
set maxversion [::p::predator::method_chainhead $IID $method] |
|
set headid [expr {$maxversion + 1}] |
|
set THISNAME $method.$headid ;#first version will be $method.1 |
|
|
|
if {$method ni [dict keys $o_methods]} { |
|
dict set o_methods $method [list arglist $arglist] |
|
} |
|
|
|
#next_script will call to lower interface in iStack if we are $method.1 |
|
set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_ |
|
#puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<" |
|
|
|
|
|
#implement |
|
#----------------------------------- |
|
set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] |
|
if {[llength [dict get $processed varspaces_with_explicit_vars]]} { |
|
foreach vs [dict get $processed varspaces_with_explicit_vars] { |
|
if {[string length $vs] && ($vs ni $o_varspaces)} { |
|
lappend o_varspaces $vs |
|
} |
|
} |
|
set body [dict get $processed body] |
|
set varDecls "" |
|
} else { |
|
set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. |
|
set body $varDecls\n[dict get $processed body] |
|
} |
|
|
|
|
|
set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist] |
|
|
|
|
|
|
|
|
|
|
|
|
|
#set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] |
|
set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] |
|
|
|
#if {[string length $varDecls]} { |
|
# puts stdout "\t---------------------------------------------------------------" |
|
# puts stdout "\t----- efficiency warning - implicit var declarations used -----" |
|
# puts stdout "\t-------- $object_command .. Method $method $arglist ---------" |
|
# puts stdout "\t[string map [list \n \t\t\n] $body]" |
|
# puts stdout "\t--------------------------" |
|
#} |
|
#invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role |
|
# while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. |
|
#(as specified by the @ operator during object conglomeration) |
|
#set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] |
|
|
|
#puts stdout "\t\t----------------------------" |
|
#puts stdout "$body" |
|
#puts stdout "\t\t----------------------------" |
|
|
|
proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body |
|
|
|
#----------------------------------- |
|
|
|
#pointer from method-name to head of override-chain |
|
interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME |
|
|
|
|
|
#point to the interface command only. The dispatcher will supply the invocant data |
|
#interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method |
|
set argvals "" |
|
foreach argspec $arglist { |
|
if {[llength $argspec] == 2} { |
|
set a [lindex $argspec 0] |
|
} else { |
|
set a $argspec |
|
} |
|
if {$a eq "args"} { |
|
append argvals " \{*\}\$args" |
|
} else { |
|
append argvals " \$$a" |
|
} |
|
} |
|
set argvals [string trimleft $argvals] |
|
#this proc directly on the object is not *just* a forwarding proc |
|
# - it provides a context in which the 'uplevel 1' from the running interface proc runs |
|
#This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) |
|
|
|
#we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain |
|
|
|
proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { |
|
::p::${IID}::_iface::$method \$_ID_ $argvals |
|
}] |
|
|
|
|
|
if 0 { |
|
if {[llength $argvals]} { |
|
proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { |
|
apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ |
|
}] |
|
} else { |
|
|
|
proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { |
|
apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ |
|
}] |
|
|
|
} |
|
} |
|
|
|
|
|
#proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { |
|
# ::p::${IID}::_iface::$method \$_ID_ $argvals |
|
#}] |
|
|
|
#todo - for o_varspaces |
|
#install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method |
|
#- this should work correctly with the 'uplevel 1' procs in the interfaces |
|
|
|
|
|
if {[string length $o_varspace]} { |
|
if {[string match "::*" $o_varspace]} { |
|
namespace eval $o_varspace {} |
|
} else { |
|
namespace eval ::p::${OID}::$o_varspace {} |
|
} |
|
} |
|
|
|
|
|
#if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. |
|
set colMethods ::p::${OID}::_meta::>colMethods |
|
|
|
if {[namespace which $colMethods] ne ""} { |
|
if {![$colMethods . hasKey $method]} { |
|
$colMethods . add [::p::internals::predator $_ID_ . $method .] $method |
|
} |
|
} |
|
|
|
#::p::-1::update_invocant_aliases $_ID_ |
|
return |
|
#::>pattern .. Create [::>pattern .. Namespace]::>method_??? |
|
#return $method_object |
|
} |
|
|
|
|
|
dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}} |
|
proc ::p::-1::V {_ID_ {glob *}} { |
|
set invocants [dict get $_ID_ i] |
|
#set invocant_alias [lindex [dict get $invocants this] 0] |
|
#set invocant [lindex [interp alias {} $invocant_alias] 1] |
|
|
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces |
|
|
|
|
|
|
|
set vlist [list] |
|
foreach IID $ifaces { |
|
dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { |
|
if {[string match $glob $vname]} { |
|
lappend vlist $vname |
|
} |
|
} |
|
} |
|
|
|
|
|
return $vlist |
|
} |
|
|
|
#experiment from http://wiki.tcl.tk/4884 |
|
proc p::predator::pipeline {args} { |
|
set lambda {return -level 0} |
|
foreach arg $args { |
|
set lambda [list apply [dict get { |
|
toupper {{lambda input} {string toupper [{*}$lambda $input]}} |
|
tolower {{lambda input} {string tolower [{*}$lambda $input]}} |
|
totitle {{lambda input} {string totitle [{*}$lambda $input]}} |
|
prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}} |
|
suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}} |
|
} [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]] |
|
} |
|
return $lambda |
|
} |
|
|
|
proc ::p::predator::get_apply_arg_0_oid {} { |
|
set apply_args [lrange [info level 0] 2 end] |
|
puts stderr ">>>>> apply_args:'$apply_args'<<<<" |
|
set invocant [lindex $apply_args 0] |
|
return [lindex [dict get $invocant i this] 0 0] |
|
} |
|
proc ::p::predator::get_oid {} { |
|
#puts stderr "---->> [info level 1] <<-----" |
|
set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 |
|
tailcall lindex [dict get $_ID_ i this] 0 0 |
|
} |
|
|
|
#todo - make sure this is called for all script installations - e.g propertyread etc etc |
|
#Add tests to check code runs in correct namespace |
|
#review - how does 'Varspace' command affect this? |
|
proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} { |
|
#use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) |
|
set arglist_apply "" |
|
append arglist_apply "\$_ID_ " |
|
foreach a $arglist { |
|
if {$a eq "args"} { |
|
append arglist_apply "{*}\$args" |
|
} else { |
|
append arglist_apply "\$[lindex $a 0] " |
|
} |
|
} |
|
#!todo - allow fully qualified varspaces |
|
if {[string length $varspace]} { |
|
if {[string match ::* $varspace]} { |
|
return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply" |
|
} else { |
|
#return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n" |
|
return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply" |
|
} |
|
} else { |
|
#return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" |
|
#return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" |
|
|
|
set script "tailcall apply \[list \{_ID_" |
|
|
|
if {[llength $arglist]} { |
|
append script " $arglist" |
|
} |
|
append script "\} \{" |
|
append script $body |
|
append script "\} ::p::@OID@\] " |
|
append script $arglist_apply |
|
#puts stderr "\n88888888888888888888888888\n\t$script\n" |
|
#puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" |
|
#return $script |
|
|
|
|
|
#----------------------------------------------------------------------------- |
|
# 2018 candidates |
|
# |
|
#return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled |
|
#return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled |
|
|
|
|
|
#this has problems with @next@ arguments! (also script variables will possibly interfere with each other) |
|
#faster though. |
|
#return "uplevel 1 \{$body\}" |
|
return "uplevel 1 [list $body]" |
|
#----------------------------------------------------------------------------- |
|
|
|
|
|
|
|
|
|
#set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" |
|
#return "uplevel 1 \{$script\}" |
|
|
|
#return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail |
|
#return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail |
|
|
|
|
|
|
|
#return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong |
|
|
|
#return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns |
|
|
|
|
|
#experiment with different dispatch mechanism (interp alias with 'namespace inscope') |
|
#----------- |
|
#return "apply { {_ID_ $arglist} {$body}} $arglist_apply" |
|
|
|
|
|
#return "uplevel 1 \{$body\}" ;#do nothing |
|
|
|
#---------- |
|
|
|
#return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) |
|
|
|
#return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body |
|
|
|
#return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker |
|
|
|
#return "tailcall " |
|
|
|
|
|
} |
|
} |
|
|
|
|
|
#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies. |
|
#expand 'var' statements inline in method bodies |
|
#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements. |
|
# |
|
#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces |
|
#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches! |
|
# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements. |
|
#Think of var & varspace statments as a form of compile-time 'macro' |
|
# |
|
#caters for 2-element lists as arguments to var statement to allow 'aliasing' |
|
#e.g var o_thing {o_data mydata} |
|
# this will upvar o_thing as o_thing & o_data as mydata |
|
# |
|
proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { |
|
set body {} |
|
|
|
#keep count of any explicit var statments per varspace in 'numDeclared' array |
|
# don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements. |
|
|
|
#default varspace is "" |
|
#varspace should only have leading :: if it is an absolute namespace path. |
|
|
|
|
|
foreach ln [split $rawbody \n] { |
|
set trimline [string trim $ln] |
|
|
|
if {$trimline eq "var"} { |
|
#plain var statement alone indicates we don't have any explicit declarations in this branch |
|
# and we don't want implicit declarations for the current varspace either. |
|
#!todo - implement test |
|
|
|
incr numDeclared($varspace) |
|
|
|
#may be further var statements e.g - in other code branches |
|
#return [list body $rawbody varspaces_with_explicit_vars 1] |
|
} elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { |
|
|
|
#append body " upvar #0 " |
|
#append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " |
|
#append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " |
|
|
|
if {$varspace eq ""} { |
|
append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " |
|
} else { |
|
if {[string match "::*" $varspace]} { |
|
append body " namespace upvar $varspace " |
|
} else { |
|
append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " |
|
} |
|
} |
|
|
|
#any whitespace before or betw var names doesn't matter - about to use as list. |
|
foreach varspec [string range $trimline 4 end] { |
|
lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. |
|
##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " |
|
#append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " |
|
|
|
append body "$var $alias " |
|
|
|
} |
|
append body \n |
|
|
|
incr numDeclared($varspace) |
|
} elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { |
|
#2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? |
|
#it is assumed there is a single word following the 'varspace' keyword. |
|
set varspace [string trim [string range $trimline 9 end]] |
|
|
|
if {$varspace in [list {{}} {""}]} { |
|
set varspace "" |
|
} |
|
if {[string length $varspace]} { |
|
#set varspace ::${varspace}:: |
|
#no need to initialize numDeclared($varspace) incr will work anyway. |
|
#if {![info exists numDeclared($varspace)]} { |
|
# set numDeclared($varspace) 0 |
|
#} |
|
|
|
if {[string match "::*" $varspace]} { |
|
append body "namespace eval $varspace {} \n" |
|
} else { |
|
append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n" |
|
} |
|
|
|
#puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} " |
|
#append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n" |
|
#append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n" |
|
|
|
#append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n" |
|
} |
|
#!review - why? why do we need the magic 'default' name instead of just using the empty string? |
|
#if varspace argument was empty string - leave it alone |
|
} else { |
|
append body $ln\n |
|
} |
|
} |
|
|
|
|
|
|
|
set varspaces [array names numDeclared] |
|
return [list body $body varspaces_with_explicit_vars $varspaces] |
|
} |
|
|
|
|
|
|
|
|
|
#Interface Variables |
|
dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} |
|
proc ::p::-1::IV {_ID_ {glob *}} { |
|
set invocants [dict get $_ID_ i] |
|
|
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces |
|
|
|
|
|
#!todo - test |
|
#return [dict keys ::p::${OID}::_iface::o_variables $glob] |
|
|
|
set members [list] |
|
foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { |
|
if {[string match $glob $vname]} { |
|
lappend members $vname |
|
} |
|
} |
|
return $members |
|
} |
|
|
|
|
|
dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}} |
|
proc ::p::-1::Methods {_ID_ {idx ""}} { |
|
set invocants [dict get $_ID_ i] |
|
set this_invocant [lindex [dict get $invocants this] 0] |
|
lassign $this_invocant OID _etc |
|
#set map [dict get $this_info map] |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
|
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces |
|
|
|
set col ::p::${OID}::_meta::>colMethods |
|
|
|
if {[namespace which $col] eq ""} { |
|
patternlib::>collection .. Create $col |
|
foreach IID $ifaces { |
|
foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { |
|
if {![$col . hasIndex $m]} { |
|
#todo - create some sort of lazy-evaluating method object? |
|
#set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist] |
|
$col . add [::p::internals::predator $_ID_ . $m .] $m |
|
} |
|
} |
|
} |
|
} |
|
|
|
if {[string length $idx]} { |
|
return [$col . item $idx] |
|
} else { |
|
return $col |
|
} |
|
} |
|
|
|
dict set ::p::-1::_iface::o_methods M {arglist {}} |
|
proc ::p::-1::M {_ID_} { |
|
set invocants [dict get $_ID_ i] |
|
set this_invocant [lindex [dict get $invocants this] 0] |
|
lassign $this_invocant OID _etc |
|
#set map [dict get $this_info map] |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
|
|
|
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces |
|
|
|
set members [list] |
|
foreach IID $ifaces { |
|
foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { |
|
lappend members $m |
|
} |
|
} |
|
return $members |
|
} |
|
|
|
|
|
#review |
|
#Interface Methods |
|
dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}} |
|
proc ::p::-1::IM {_ID_ {glob *}} { |
|
set invocants [dict get $_ID_ i] |
|
set this_invocant [lindex [dict get $invocants this] 0] |
|
lassign $this_invocant OID _etc |
|
#set map [dict get $this_info map] |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
|
|
|
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces |
|
|
|
return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] |
|
|
|
} |
|
|
|
|
|
|
|
dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}} |
|
proc ::p::-1::InterfaceStacks {_ID_} { |
|
upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP |
|
return [dict get $MAP interfaces level0] |
|
} |
|
|
|
|
|
dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}} |
|
proc ::p::-1::PatternStacks {_ID_} { |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
return [dict get $MAP interfaces level1] |
|
} |
|
|
|
|
|
#!todo fix. need to account for references which were never set to a value |
|
dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}} |
|
proc ::p::-1::DeletePropertyReferences {_ID_} { |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
set cleared_references [list] |
|
set refvars [info vars ::p::${OID}::_ref::*] |
|
#unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. |
|
foreach rv $refvars { |
|
foreach tinfo [trace info variable $rv] { |
|
set ops {}; set cmd {} |
|
lassign $tinfo ops cmd |
|
trace remove variable $rv $ops $cmd |
|
} |
|
unset $rv |
|
lappend cleared_references $rv |
|
} |
|
|
|
|
|
return [list deleted_property_references $cleared_references] |
|
} |
|
|
|
dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}} |
|
proc ::p::-1::DeleteMethodReferences {_ID_} { |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
set cleared_references [list] |
|
|
|
set iflist [dict get $MAP interfaces level0] |
|
set iflist_reverse [lreferse $iflist] |
|
#set iflist [dict get $MAP interfaces level0] |
|
|
|
|
|
set refcommands [info commands ::p::${OID}::_ref::*] |
|
foreach c $refcommands { |
|
set reftail [namespace tail $c] |
|
set field [lindex [split $c +] 0] |
|
set field_is_a_method 0 |
|
foreach IFID $iflist_reverse { |
|
if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { |
|
set field_is_a_method 1 |
|
break |
|
} |
|
} |
|
if {$field_is_a_method} { |
|
#what if it's also a property? |
|
interp alias {} $c {} |
|
lappend cleared_references $c |
|
} |
|
} |
|
|
|
|
|
return [list deleted_method_references $cleared_references] |
|
} |
|
|
|
|
|
dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}} |
|
proc ::p::-1::DeleteReferences {_ID_} { |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias default_method this |
|
|
|
set result [dict create] |
|
dict set result {*}[$this .. DeletePropertyReferences] |
|
dict set result {*}[$this .. DeleteMethodReferences] |
|
|
|
return $result |
|
} |
|
|
|
## |
|
#Digest |
|
# |
|
#!todo - review |
|
# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!) |
|
# |
|
#!todo - write tests - check that digest changes when properties of contained objects change value |
|
# |
|
#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method? |
|
# |
|
dict set ::p::-1::_iface::o_methods Digest {arglist {args}} |
|
proc ::p::-1::Digest {_ID_ args} { |
|
set invocants [dict get $_ID_ i] |
|
# md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway. |
|
#set this_invocant [lindex [dict get $invocants this] 0] |
|
#lassign $this_invocant OID _etc |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] _OID alias default_method this |
|
|
|
|
|
set interface_ids [dict get $MAP interfaces level0] |
|
set IFID0 [lindex $interface_ids end] |
|
|
|
set known_flags {-recursive -algorithm -a -indent} |
|
set defaults {-recursive 1 -algorithm md5 -indent ""} |
|
if {[dict exists $args -a] && ![dict exists $args -algorithm]} { |
|
dict set args -algorithm [dict get $args -a] |
|
} |
|
|
|
set opts [dict merge $defaults $args] |
|
foreach key [dict keys $opts] { |
|
if {$key ni $known_flags} { |
|
error "unknown option $key. Expected only: $known_flags" |
|
} |
|
} |
|
|
|
|
|
set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256} |
|
if {[dict get $opts -algorithm] ni $known_algos} { |
|
error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos" |
|
} |
|
set algo [string tolower [dict get $opts -algorithm]] |
|
|
|
# append comma for each var so that all changes in adjacent vars detectable. |
|
# i.e set x 34; set y 5 |
|
# must be distinguishable from: |
|
# set x 3; set y 45 |
|
|
|
if {[dict get $opts -indent] ne ""} { |
|
set state "" |
|
set indent "[dict get $opts -indent]" |
|
} else { |
|
set state "---\n" |
|
set indent " " |
|
} |
|
append state "${indent}object_command: $this\n" |
|
set indent "${indent} " |
|
|
|
#append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state. |
|
append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state. |
|
|
|
|
|
|
|
|
|
#!todo - recurse into 'varspaces' |
|
set varspaces_found [list] |
|
append state "${indent}interfaces:\n" |
|
foreach IID $interface_ids { |
|
append state "${indent} - interface: $IID\n" |
|
namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces |
|
append state "${indent} varspaces:\n" |
|
foreach vs $local_o_varspaces { |
|
if {$vs ni $varspaces_found} { |
|
lappend varspaces_found $vs |
|
append state "${indent} - varspace: $vs\n" |
|
} |
|
} |
|
} |
|
|
|
append state "${indent}vars:\n" |
|
foreach var [info vars ::p::${OID}::*] { |
|
append state "${indent} - [namespace tail $var] : \"" |
|
if {[catch {append state "[set $var]"}]} { |
|
append state "[array get $var]" |
|
} |
|
append state "\"\n" |
|
} |
|
|
|
if {[dict get $opts -recursive]} { |
|
append state "${indent}sub-objects:\n" |
|
set subargs $args |
|
dict set subargs -indent "$indent " |
|
foreach obj [info commands ::p::${OID}::>*] { |
|
append state "[$obj .. Digest {*}$subargs]\n" |
|
} |
|
|
|
append state "${indent}sub-namespaces:\n" |
|
set subargs $args |
|
dict set subargs -indent "$indent " |
|
foreach ns [namespace children ::p::${OID}] { |
|
append state "${indent} - namespace: $ns\n" |
|
foreach obj [info commands ${ns}::>*] { |
|
append state "[$obj .. Digest {*}$subargs]\n" |
|
} |
|
} |
|
} |
|
|
|
|
|
if {$algo in {"" raw none}} { |
|
return $state |
|
} else { |
|
if {$algo eq "md5"} { |
|
package require md5 |
|
return [::md5::md5 -hex $state] |
|
} elseif {$algo eq "sha256"} { |
|
package require sha256 |
|
return [::sha2::sha256 -hex $state] |
|
} elseif {$algo eq "blowfish"} { |
|
package require patterncipher |
|
patterncipher::>blowfish .. Create >b1 |
|
set [>b1 . key .] 12341234 |
|
>b1 . encrypt $state -final 1 |
|
set result [>b1 . ciphertext] |
|
>b1 .. Destroy |
|
|
|
} elseif {$algo eq "blowfish-binary"} { |
|
|
|
} else { |
|
error "can't get here" |
|
} |
|
|
|
} |
|
} |
|
|
|
|
|
dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}} |
|
proc ::p::-1::Variable {_ID_ varname args} { |
|
set invocants [dict get $_ID_ i] |
|
|
|
#set invocant_alias [lindex [dict get $invocants this] 0] |
|
#set invocant [lindex [interp alias {} $invocant_alias] 1] |
|
|
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
#this interface itself is always a co-invocant |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
set interfaces [dict get $MAP interfaces level0] |
|
|
|
#set existing_IID [lindex $map 1 0 end] |
|
set existing_IID [lindex $interfaces end] |
|
|
|
set prev_openstate [set ::p::${existing_IID}::_iface::o_open] |
|
|
|
if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { |
|
#IID changed |
|
#remove ourself from the usedby list of the previous interface |
|
array unset ::p::${existing_IID}::_iface::o_usedby i$OID |
|
set ::p::${IID}::_iface::o_usedby(i$OID) $cmd |
|
|
|
set posn [lsearch $interfaces $existing_IID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] |
|
|
|
|
|
#update original object command |
|
set ::p::${IID}::_iface::o_open 0 |
|
} else { |
|
set ::p::${IID}::_iface::o_open $prev_openstate |
|
} |
|
|
|
set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface) |
|
|
|
if {[llength $args]} { |
|
#!assume var not already present on interface - it is an error to define twice (?) |
|
#lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] |
|
dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] |
|
|
|
|
|
#Implement if there is a default |
|
#!todo - correct behaviour when overlaying on existing object with existing var of this name? |
|
#if {[string length $varspace]} { |
|
# set ::p::${OID}::${varspace}::$varname [lindex $args 0] |
|
#} else { |
|
set ::p::${OID}::$varname [lindex $args 0] |
|
#} |
|
} else { |
|
#lappend ::p::${IID}::_iface::o_variables [list $varname] |
|
dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] |
|
} |
|
|
|
#varspace '_iface' |
|
|
|
return |
|
} |
|
|
|
|
|
#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility |
|
|
|
dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}} |
|
proc ::p::-1::PatternVariable {_ID_ varname args} { |
|
set invocants [dict get $_ID_ i] |
|
|
|
#set invocant_alias [lindex [dict get $invocants this] 0] |
|
#set invocant [lindex [interp alias {} $invocant_alias] 1] |
|
##this interface itself is always a co-invocant |
|
#lassign [lindex $invocant 0 ] OID alias itemCmd cmd |
|
|
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
|
|
|
|
set patterns [dict get $MAP interfaces level1] |
|
set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. |
|
set iface ::p::ifaces::>$iid_top |
|
|
|
if {(![string length $iid_top]) || ([$iface . isClosed])} { |
|
#no existing pattern - create a new interface |
|
set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id |
|
set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 [concat $patterns $iid_top] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 1} [concat $patterns $iid_top] |
|
} |
|
set IID $iid_top |
|
|
|
set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. |
|
|
|
|
|
if {[llength $args]} { |
|
#lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] |
|
dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] |
|
} else { |
|
dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] |
|
} |
|
|
|
return |
|
} |
|
|
|
dict set ::p::-1::_iface::o_methods Varspaces {arglist args} |
|
proc ::p::-1::Varspaces {_ID_ args} { |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
if {![llength $args]} { |
|
#query |
|
set iid_top [lindex [dict get $MAP interfaces level0] end] |
|
set iface ::p::ifaces::>$iid_top |
|
if {![string length $iid_top]} { |
|
error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " |
|
} elseif {[$iface . isClosed]} { |
|
error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " |
|
} |
|
return [set ::p::${iid_top}::_iface::o_varspaces] |
|
} |
|
set IID [::p::predator::get_possibly_new_open_interface $OID] |
|
namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces |
|
|
|
set varspaces $args |
|
foreach vs $varspaces { |
|
if {[string length $vs] && ($vs ni $o_varspaces)} { |
|
if {[string match ::* $vs} { |
|
namespace eval $vs {} |
|
} else { |
|
namespace eval ::p::${OID}::$vs {} |
|
} |
|
lappend o_varspaces $vs |
|
} |
|
} |
|
return $o_varspaces |
|
} |
|
|
|
#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface |
|
dict set ::p::-1::_iface::o_methods Varspace {arglist args} |
|
# set the default varspace for the interface, so that new methods/properties refer to it. |
|
# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. |
|
proc ::p::-1::Varspace {_ID_ args} { |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
|
|
if {![llength $args]} { |
|
#query |
|
set iid_top [lindex [dict get $MAP interfaces level0] end] |
|
set iface ::p::ifaces::>$iid_top |
|
if {![string length $iid_top]} { |
|
error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " |
|
} elseif {[$iface . isClosed]} { |
|
error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " |
|
} |
|
return [set ::p::${iid_top}::_iface::o_varspace] |
|
} |
|
set varspace [lindex $args 0] |
|
|
|
#set interfaces [dict get $MAP interfaces level0] |
|
#set iid_top [lindex $interfaces end] |
|
|
|
set IID [::p::predator::get_possibly_new_open_interface $OID] |
|
|
|
|
|
#namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace |
|
namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces |
|
|
|
if {[string length $varspace]} { |
|
#ensure namespace exists !? do after list test? |
|
if {[string match ::* $varspace]} { |
|
namespace eval $varspace {} |
|
} else { |
|
namespace eval ::p::${OID}::$varspace {} |
|
} |
|
if {$varspace ni $o_varspaces} { |
|
lappend o_varspaces $varspace |
|
} |
|
} |
|
set o_varspace $varspace |
|
} |
|
|
|
|
|
proc ::p::predator::get_possibly_new_open_interface {OID} { |
|
#we need to re-upvar MAP rather than using a parameter - as we need to write back to it |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
set interfaces [dict get $MAP interfaces level0] |
|
set iid_top [lindex $interfaces end] |
|
|
|
|
|
set iface ::p::ifaces::>$iid_top |
|
if {(![string length $iid_top]) || ([$iface . isClosed])} { |
|
#no existing pattern - create a new interface |
|
set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id |
|
#puts stderr ">>>>creating new interface $iid_top" |
|
set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level0 [concat $interfaces $iid_top] |
|
dict set MAP interfaces $extracted_sub_dict |
|
} |
|
|
|
return $iid_top |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
################################################################################################################################################### |
|
|
|
################################################################################################################################################### |
|
dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}} |
|
# set the default varspace for the interface, so that new methods/properties refer to it. |
|
# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. |
|
proc ::p::-1::PatternVarspace {_ID_ varspace args} { |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
set patterns [dict get $MAP interfaces level1] |
|
set iid_top [lindex $patterns end] |
|
|
|
set iface ::p::ifaces::>$iid_top |
|
if {(![string length $iid_top]) || ([$iface . isClosed])} { |
|
#no existing pattern - create a new interface |
|
set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id |
|
set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 [concat $patterns $iid_top] |
|
dict set MAP interfaces $extracted_sub_dict |
|
} |
|
set IID $iid_top |
|
|
|
namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces |
|
if {[string length $varspace]} { |
|
if {$varspace ni $o_varspaces} { |
|
lappend o_varspaces $varspace |
|
} |
|
} |
|
#o_varspace is the currently active varspace |
|
set o_varspace $varspace |
|
|
|
} |
|
################################################################################################################################################### |
|
|
|
#get varspace and default from highest interface - return all interface ids which define it |
|
dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}} |
|
proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} { |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
set interfaces [dict get $MAP interfaces level0] |
|
|
|
array set propinfo {} |
|
set found_property_names [list] |
|
#start at the lowest and work up (normal storage order of $interfaces) |
|
foreach iid $interfaces { |
|
set propinfodict [set ::p::${iid}::_iface::o_properties] |
|
set matching_propnames [dict keys $propinfodict $propnamepattern] |
|
foreach propname $matching_propnames { |
|
if {$propname ni $found_property_names} { |
|
lappend found_property_names $propname |
|
} |
|
lappend propinfo($propname,interfaces) $iid |
|
;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one |
|
if {[dict exists $propinfodict $propname default]} { |
|
set propinfo($propname,default) [dict get $propinfodict $propname default] |
|
} |
|
set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] |
|
} |
|
} |
|
|
|
set resultdict [dict create] |
|
foreach propname $found_property_names { |
|
set fields [list varspace $propinfo($propname,varspace)] |
|
if {[array exists propinfo($propname,default)]} { |
|
lappend fields default [set propinfo($propname,default)] |
|
} |
|
lappend fields interfaces $propinfo($propname,interfaces) |
|
dict set resultdict $propname $fields |
|
} |
|
return $resultdict |
|
} |
|
|
|
|
|
dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args} |
|
proc ::p::-1::GetTopPattern {_ID_ args} { |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
|
|
set interfaces [dict get $MAP interfaces level1] |
|
set iid_top [lindex $interfaces end] |
|
if {![string length $iid_top]} { |
|
lassign [dict get $MAP invocantdata] OID _alias _default_method object_command |
|
error "No installed level1 interfaces (patterns) for object $object_command" |
|
} |
|
return ::p::ifaces::>$iid_top |
|
} |
|
|
|
|
|
|
|
dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args} |
|
proc ::p::-1::GetTopInterface {_ID_ args} { |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
|
|
set iid_top [lindex [dict get $MAP interfaces level0] end] |
|
if {![string length $iid_top]} { |
|
lassign [dict get $MAP invocantdata] OID _alias _default_method object_command |
|
error "No installed level0 interfaces for object $object_command" |
|
} |
|
return ::p::ifaces::>$iid_top |
|
} |
|
|
|
|
|
dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} |
|
proc ::p::-1::GetExpandableInterface {_ID_ args} { |
|
|
|
} |
|
|
|
|
|
|
|
|
|
|
|
################################################################################################################################################### |
|
|
|
################################################################################################################################################### |
|
dict set ::p::-1::_iface::o_methods Property {arglist {property args}} |
|
proc ::p::-1::Property {_ID_ property args} { |
|
#puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args" |
|
#set invocants [dict get $_ID_ i] |
|
#set invocant_roles [dict keys $invocants] |
|
if {[llength $args] > 1} { |
|
error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)" |
|
} |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
|
|
set interfaces [dict get $MAP interfaces level0] |
|
set iid_top [lindex $interfaces end] |
|
|
|
set prev_openstate [set ::p::${iid_top}::_iface::o_open] |
|
|
|
set iface ::p::ifaces::>$iid_top |
|
|
|
|
|
if {(![string length $iid_top]) || ([$iface . isClosed])} { |
|
#create a new interface |
|
set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id |
|
set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level0 [concat $interfaces $iid_top] |
|
dict set MAP interfaces $extracted_sub_dict |
|
} |
|
set IID $iid_top |
|
|
|
|
|
namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace |
|
|
|
|
|
set maxversion [::p::predator::method_chainhead $IID (GET)$property] |
|
set headid [expr {$maxversion + 1}] |
|
set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 |
|
|
|
|
|
if {$headid == 1} { |
|
#implementation |
|
#interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property |
|
|
|
#if {$o_varspace eq ""} { |
|
# set ns ::p::${OID} |
|
#} else { |
|
# if {[string match "::*" $o_varspace]} { |
|
# set ns $o_varspace |
|
# } else { |
|
# set ns ::p::${OID}::$o_varspace |
|
# } |
|
#} |
|
#proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]] |
|
|
|
proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]] |
|
|
|
|
|
#interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property |
|
proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] |
|
|
|
|
|
#chainhead pointers |
|
interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 |
|
interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 |
|
|
|
|
|
} |
|
|
|
if {($property ni [dict keys $o_methods])} { |
|
interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property |
|
} |
|
|
|
|
|
|
|
#installation on object |
|
|
|
#namespace eval ::p::${OID} [list namespace export $property] |
|
|
|
|
|
|
|
#obsolete? |
|
#if {$property ni [P $_ID_]} { |
|
#only link objects (GET)/(SET) for this property if property not present on any of our other interfaces |
|
#interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant |
|
#interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant |
|
#} |
|
|
|
#link main (GET)/(SET) to this interface |
|
interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property |
|
interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property |
|
|
|
#Only install property if no method of same name already installed here. |
|
#(Method takes precedence over property because property always accessible via 'set' reference) |
|
#convenience pointer to chainhead pointer. |
|
if {$property ni [M $_ID_]} { |
|
interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property |
|
} else { |
|
#property with same name as method - we need to make sure the refMisuse_traceHandler is fixed |
|
|
|
|
|
} |
|
|
|
|
|
set varspace [set ::p::${IID}::_iface::o_varspace] |
|
|
|
|
|
|
|
#Install the matching Variable |
|
#!todo - which should take preference if Variable also given a default? |
|
#if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { |
|
# set o_variables [lreplace $o_variables $posn $posn o_$property] |
|
#} else { |
|
# lappend o_variables [list o_$property] |
|
#} |
|
dict set o_variables o_$property [list varspace $varspace] |
|
|
|
|
|
|
|
|
|
if {[llength $args]} { |
|
#should store default once only! |
|
#set IFINFO(v,default,o_$property) $default |
|
|
|
set default [lindex $args end] |
|
|
|
dict set o_properties $property [list default $default varspace $varspace] |
|
|
|
#if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { |
|
# set o_properties [lreplace $o_properties $posn $posn [list $property $default]] |
|
#} else { |
|
# lappend o_properties [list $property $default] |
|
#} |
|
|
|
if {$varspace eq ""} { |
|
set ns ::p::${OID} |
|
} else { |
|
if {[string match "::*" $varspace]} { |
|
set ns $varspace |
|
} else { |
|
set ns ::p::${OID}::$o_varspace |
|
} |
|
} |
|
|
|
set ${ns}::o_$property $default |
|
#set ::p::${OID}::o_$property $default |
|
} else { |
|
|
|
#if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { |
|
# set o_properties [lreplace $o_properties $posn $posn [list $property]] |
|
#} else { |
|
# lappend o_properties [list $property] |
|
#} |
|
dict set o_properties $property [list varspace $varspace] |
|
|
|
|
|
#variable ::p::${OID}::o_$property |
|
} |
|
|
|
|
|
|
|
|
|
|
|
#if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. |
|
#!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) |
|
#catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} |
|
|
|
set colProperties ::p::${OID}::_meta::>colProperties |
|
if {[namespace which $colProperties] ne ""} { |
|
if {![$colProperties . hasKey $property]} { |
|
$colProperties . add [::p::internals::predator $_ID_ . $property .] $property |
|
} |
|
} |
|
|
|
return |
|
} |
|
################################################################################################################################################### |
|
|
|
|
|
|
|
################################################################################################################################################### |
|
|
|
################################################################################################################################################### |
|
interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility |
|
dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}} |
|
proc ::p::-1::PatternProperty {_ID_ property args} { |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
|
|
set patterns [dict get $MAP interfaces level1] |
|
set iid_top [lindex $patterns end] |
|
|
|
set iface ::p::ifaces::>$iid_top |
|
|
|
if {(![string length $iid_top]) || ([$iface . isClosed])} { |
|
set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id |
|
set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] |
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 [concat $patterns $iid_top] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 1} [concat $patterns $iid_top] |
|
} |
|
set IID $iid_top |
|
|
|
namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace |
|
|
|
|
|
set maxversion [::p::predator::method_chainhead $IID (GET)$property] |
|
set headid [expr {$maxversion + 1}] |
|
set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 |
|
|
|
|
|
|
|
if {$headid == 1} { |
|
#implementation |
|
#interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property |
|
proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]] |
|
#interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property |
|
proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] |
|
|
|
|
|
#chainhead pointers |
|
interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 |
|
interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 |
|
|
|
} |
|
|
|
if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} { |
|
interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property |
|
} |
|
|
|
set varspace [set ::p::${IID}::_iface::o_varspace] |
|
|
|
#Install the matching Variable |
|
#!todo - which should take preference if Variable also given a default? |
|
#if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { |
|
# set o_variables [lreplace $o_variables $posn $posn o_$property] |
|
#} else { |
|
# lappend o_variables [list o_$property] |
|
#} |
|
dict set o_variables o_$property [list varspace $varspace] |
|
|
|
set argc [llength $args] |
|
|
|
if {$argc} { |
|
if {$argc == 1} { |
|
set default [lindex $args 0] |
|
dict set o_properties $property [list default $default varspace $varspace] |
|
} else { |
|
#if more than one arg - treat as a dict of options. |
|
if {[dict exists $args -default]} { |
|
set default [dict get $args -default] |
|
dict set o_properties $property [list default $default varspace $varspace] |
|
} else { |
|
#no default value |
|
dict set o_properties $property [list varspace $varspace] |
|
} |
|
} |
|
#! only set default for property... not underlying variable. |
|
#lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]] |
|
} else { |
|
dict set o_properties $property [list varspace $varspace] |
|
} |
|
return |
|
} |
|
################################################################################################################################################### |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
################################################################################################################################################### |
|
|
|
################################################################################################################################################### |
|
dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}} |
|
proc ::p::-1::PatternPropertyRead {_ID_ property args} { |
|
set invocants [dict get $_ID_ i] |
|
|
|
set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' |
|
set OID [lindex $this_invocant 0] |
|
#set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias defaut_command cmd |
|
|
|
set patterns [dict get $MAP interfaces level1] |
|
set existing_IID [lindex $patterns end] |
|
|
|
set idxlist [::list] |
|
if {[llength $args] == 1} { |
|
set body [lindex $args 0] |
|
} elseif {[llength $args] == 2} { |
|
lassign $args idxlist body |
|
} else { |
|
error "wrong # args: should be \"property body\" or \"property idxlist body\"" |
|
} |
|
|
|
|
|
if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { |
|
#remove ourself from the usedby list of the previous interface |
|
array unset ::p::${existing_IID}::_iface::o_usedby i$OID |
|
set ::p::${IID}::_iface::o_usedby(i$OID) $cmd |
|
|
|
set posn [lsearch $patterns $existing_IID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] |
|
|
|
} else { |
|
set prev_open [set ::p::${existing_IID}::_iface::o_open] |
|
set ::p::${IID}::_iface::o_open $prev_open |
|
} |
|
|
|
namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace |
|
|
|
set maxversion [::p::predator::method_chainhead $IID (GET)$property] |
|
set headid [expr {$maxversion + 1}] |
|
if {$headid == 1} { |
|
set headid 2 ;#reserve 1 for the getprop of the underlying property |
|
} |
|
|
|
set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 |
|
set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ |
|
|
|
|
|
#implement |
|
#----------------------------------- |
|
|
|
|
|
set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] |
|
if {[llength [dict get $processed varspaces_with_explicit_vars]]} { |
|
foreach vs [dict get $processed varspaces_with_explicit_vars] { |
|
if {[string length $vs] && ($vs ni $o_varspaces)} { |
|
lappend o_varspaces $vs |
|
} |
|
} |
|
set body [dict get $processed body] |
|
} else { |
|
|
|
set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. |
|
set body $varDecls[dict get $processed body] |
|
} |
|
#set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] |
|
set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] |
|
|
|
|
|
#implementation |
|
if {![llength $idxlist]} { |
|
proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body |
|
} else { |
|
#what are we trying to achieve here? .. |
|
proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body |
|
} |
|
|
|
|
|
#----------------------------------- |
|
|
|
|
|
#adjust chain-head pointer to point to new head. |
|
interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid |
|
|
|
return |
|
} |
|
################################################################################################################################################### |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
################################################################################################################################################### |
|
|
|
################################################################################################################################################### |
|
dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}} |
|
proc ::p::-1::PropertyRead {_ID_ property args} { |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
|
|
#assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead) |
|
lassign [dict get $MAP invocantdata] OID alias default_command cmd |
|
|
|
set interfaces [dict get $MAP interfaces level0] |
|
set existing_IID [lindex $interfaces end] |
|
|
|
|
|
set idxlist [::list] |
|
if {[llength $args] == 1} { |
|
set body [lindex $args 0] |
|
} elseif {[llength $args] == 2} { |
|
lassign $args idxlist body |
|
} else { |
|
error "wrong # args: should be \"property body\" or \"property idxlist body\"" |
|
} |
|
|
|
|
|
if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { |
|
#remove ourself from the usedby list of the previous interface |
|
array unset ::p::${existing_IID}::_iface::o_usedby i$OID |
|
set ::p::${IID}::_iface::o_usedby(i$OID) $cmd |
|
|
|
set posn [lsearch $interfaces $existing_IID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] |
|
dict set MAP interfaces $extracted_sub_dict |
|
|
|
set ::p::${IID}::_iface::o_open 0 |
|
} else { |
|
set prev_open [set ::p::${existing_IID}::_iface::o_open] |
|
set ::p::${IID}::_iface::o_open $prev_open |
|
} |
|
namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace |
|
|
|
#array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd] |
|
|
|
|
|
set maxversion [::p::predator::method_chainhead $IID (GET)$property] |
|
set headid [expr {$maxversion + 1}] |
|
if {$headid == 1} { |
|
set headid 2 |
|
} |
|
set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself) |
|
|
|
set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] |
|
|
|
#implement |
|
#----------------------------------- |
|
|
|
set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] |
|
if {[llength [dict get $processed varspaces_with_explicit_vars]]} { |
|
foreach vs [dict get $processed varspaces_with_explicit_vars] { |
|
if {[string length $vs] && ($vs ni $o_varspaces)} { |
|
lappend o_varspaces $vs |
|
} |
|
} |
|
set body [dict get $processed body] |
|
} else { |
|
set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. |
|
set body $varDecls[dict get $processed body] |
|
} |
|
#set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] |
|
set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] |
|
|
|
proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body |
|
|
|
#----------------------------------- |
|
|
|
|
|
|
|
#pointer from prop-name to head of override-chain |
|
interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid |
|
|
|
|
|
interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name. |
|
if {$property ni [M $_ID_]} { |
|
interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property |
|
} |
|
} |
|
################################################################################################################################################### |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
################################################################################################################################################### |
|
|
|
################################################################################################################################################### |
|
dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}} |
|
proc ::p::-1::PropertyWrite {_ID_ property argname body} { |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias default_command cmd |
|
|
|
set interfaces [dict get $MAP interfaces level0] |
|
set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. |
|
|
|
|
|
|
|
if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { |
|
#remove ourself from the usedby list of the previous interface |
|
array unset ::p::${existing_IID}::_iface::o_usedby i$OID |
|
set ::p::${IID}::_iface::o_usedby(i$OID) $cmd |
|
|
|
set posn [lsearch $interfaces $existing_IID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] |
|
|
|
set ::p::${IID}::_iface::o_open 0 |
|
} else { |
|
set prev_open [set ::p::${existing_IID}::_iface::o_open] |
|
set ::p::${IID}::_iface::o_open $prev_open |
|
} |
|
namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace |
|
|
|
#pw short for propertywrite |
|
#array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] |
|
array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] |
|
|
|
|
|
set maxversion [::p::predator::method_chainhead $IID (SET)$property] |
|
set headid [expr {$maxversion + 1}] |
|
|
|
set THISNAME (SET)$property.$headid |
|
|
|
set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] |
|
|
|
#implement |
|
#----------------------------------- |
|
|
|
set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] |
|
if {[llength [dict get $processed varspaces_with_explicit_vars]]} { |
|
foreach vs [dict get $processed varspaces_with_explicit_vars] { |
|
if {[string length $vs] && ($vs ni $o_varspaces)} { |
|
lappend o_varspaces $vs |
|
} |
|
} |
|
set body [dict get $processed body] |
|
} else { |
|
set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. |
|
set body $varDecls[dict get $processed body] |
|
} |
|
#set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] |
|
set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] |
|
|
|
|
|
proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body |
|
|
|
#----------------------------------- |
|
|
|
|
|
|
|
#pointer from method-name to head of override-chain |
|
interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid |
|
} |
|
################################################################################################################################################### |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
################################################################################################################################################### |
|
|
|
################################################################################################################################################### |
|
dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}} |
|
proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias default_command cmd |
|
|
|
|
|
set patterns [dict get $MAP interfaces level1] |
|
set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. |
|
|
|
|
|
if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { |
|
#remove ourself from the usedby list of the previous interface |
|
array unset ::p::${existing_IID}::_iface::o_usedby i$OID |
|
set ::p::${IID}::_iface::o_usedby(i$OID) $cmd |
|
|
|
set existing_ifaces [lindex $map 1 1] |
|
set posn [lsearch $existing_ifaces $existing_IID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] |
|
|
|
#set ::p::${IID}::_iface::o_open 0 |
|
} else { |
|
} |
|
|
|
#pw short for propertywrite |
|
array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] |
|
|
|
|
|
|
|
|
|
return |
|
|
|
} |
|
################################################################################################################################################### |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
################################################################################################################################################### |
|
|
|
################################################################################################################################################### |
|
dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}} |
|
proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias default_command cmd |
|
|
|
|
|
set interfaces [dict get $MAP interfaces level0] |
|
set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. |
|
|
|
|
|
|
|
if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { |
|
#remove ourself from the usedby list of the previous interface |
|
array unset ::p::${existing_IID}::_iface::o_usedby i$OID |
|
set ::p::${IID}::_iface::o_usedby(i$OID) $cmd |
|
|
|
set posn [lsearch $interfaces $existing_IID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] |
|
dict set MAP interfaces $extracted_sub_dict |
|
} else { |
|
set prev_open [set ::p::${existing_IID}::_iface::o_open] |
|
set ::p::${IID}::_iface::o_open $prev_open |
|
} |
|
namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers |
|
#upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers |
|
dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] |
|
|
|
set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] |
|
set headid [expr {$maxversion + 1}] |
|
|
|
set THISNAME (UNSET)$property.$headid |
|
|
|
set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] |
|
|
|
|
|
set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] |
|
if {[llength [dict get $processed varspaces_with_explicit_vars]]} { |
|
foreach vs [dict get $processed varspaces_with_explicit_vars] { |
|
if {[string length $vs] && ($vs ni $o_varspaces)} { |
|
lappend o_varspaces $vs |
|
} |
|
} |
|
set body [dict get $processed body] |
|
} else { |
|
set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. |
|
set body $varDecls[dict get $processed body] |
|
} |
|
#set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] |
|
set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] |
|
|
|
#note $arraykeypattern actually contains the name of the argument |
|
if {[string trim $arraykeypattern] eq ""} { |
|
set arraykeypattern _dontcare_ ;# |
|
} |
|
proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body |
|
|
|
#----------------------------------- |
|
|
|
|
|
#pointer from method-name to head of override-chain |
|
interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid |
|
|
|
} |
|
################################################################################################################################################### |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
################################################################################################################################################### |
|
|
|
################################################################################################################################################### |
|
dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}} |
|
proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
|
|
|
|
set patterns [dict get $MAP interfaces level1] |
|
set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. |
|
|
|
|
|
if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { |
|
#remove ourself from the usedby list of the previous interface |
|
array unset ::p::${existing_IID}::_iface::o_usedby i$OID |
|
set ::p::${IID}::_iface::o_usedby(i$OID) $cmd |
|
|
|
set posn [lsearch $patterns $existing_IID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#set ::p::${IID}::_iface::o_open 0 |
|
} |
|
|
|
|
|
upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers |
|
dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] |
|
|
|
return |
|
} |
|
################################################################################################################################################### |
|
|
|
|
|
|
|
#lappend ::p::-1::_iface::o_methods Implements |
|
#!todo - some way to force overriding of any abstract (empty) methods from the source object |
|
#e.g leave interface open and raise an error when closing it if there are unoverridden methods? |
|
|
|
|
|
|
|
|
|
|
|
#implementation reuse - sugar for >object .. Clone >target |
|
dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}} |
|
proc ::p::-1::Extends {_ID_ pattern} { |
|
if {!([string range [namespace tail $pattern] 0 0] eq ">")} { |
|
error "'Extends' expected a pattern object" |
|
} |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd object_command |
|
|
|
|
|
tailcall $pattern .. Clone $object_command |
|
|
|
} |
|
#implementation reuse - sugar for >pattern .. Create >target |
|
dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}} |
|
proc ::p::-1::PatternExtends {_ID_ pattern} { |
|
if {!([string range [namespace tail $pattern] 0 0] eq ">")} { |
|
error "'PatternExtends' expected a pattern object" |
|
} |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd object_command |
|
|
|
|
|
tailcall $pattern .. Create $object_command |
|
} |
|
|
|
|
|
dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}} |
|
proc ::p::-1::Extend {_ID_ {idx ""}} { |
|
puts stderr "Extend is DEPRECATED - use Expand instead" |
|
tailcall ::p::-1::Expand $_ID_ $idx |
|
} |
|
|
|
#set the topmost interface on the iStack to be 'open' |
|
dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}} |
|
proc ::p::-1::Expand {_ID_ {idx ""}} { |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces |
|
set iid_top [lindex $interfaces end] |
|
set iface ::p::ifaces::>$iid_top |
|
|
|
if {![string length $iid_top]} { |
|
#no existing interface - create a new one |
|
set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id |
|
set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] |
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level0 [list $iid_top] |
|
dict set MAP interfaces $extracted_sub_dict ;#write new interface into map |
|
$iface . open |
|
return $iid_top |
|
} else { |
|
if {[$iface . isOpen]} { |
|
#already open.. |
|
#assume ready to expand.. shared or not! |
|
return $iid_top |
|
} |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
|
|
if {[$iface . refCount] > 1} { |
|
if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} { |
|
#!warning! not exercised by test suites! |
|
|
|
#remove ourself from the usedby list of the previous interface |
|
array unset ::p::${iid_top}::_iface::o_usedby i$OID |
|
set ::p::${IID}::_iface::o_usedby(i$OID) $cmd |
|
|
|
#remove existing interface & add |
|
set posn [lsearch $interfaces $iid_top] |
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] |
|
|
|
|
|
set iid_top $IID |
|
set iface ::p::ifaces::>$iid_top |
|
} |
|
} |
|
} |
|
|
|
$iface . open |
|
return $iid_top |
|
} |
|
|
|
dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}} |
|
proc ::p::-1::PatternExtend {_ID_ {idx ""}} { |
|
puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead" |
|
tailcall ::p::-1::PatternExpand $_ID_ $idx |
|
} |
|
|
|
|
|
|
|
#set the topmost interface on the pStack to be 'open' if it's not shared |
|
# if shared - 'copylink' to new interface before opening for extension |
|
dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}} |
|
proc ::p::-1::PatternExpand {_ID_ {idx ""}} { |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
::p::map $OID MAP |
|
#puts stderr "no tests written for PatternExpand " |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
|
|
set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces |
|
set iid_top [lindex $ifaces end] |
|
set iface ::p::ifaces::>$iid_top |
|
|
|
if {![string length $iid_top]} { |
|
#no existing interface - create a new one |
|
set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id |
|
set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] |
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 [list $iid_top] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 1} [list $iid_top] |
|
$iface . open |
|
return $iid_top |
|
} else { |
|
if {[$iface . isOpen]} { |
|
#already open.. |
|
#assume ready to expand.. shared or not! |
|
return $iid_top |
|
} |
|
|
|
if {[$iface . refCount] > 1} { |
|
if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} { |
|
#!WARNING! not exercised by test suite! |
|
#remove ourself from the usedby list of the previous interface |
|
array unset ::p::${iid_top}::_iface::o_usedby i$OID |
|
set ::p::${IID}::_iface::o_usedby(i$OID) $cmd |
|
|
|
set posn [lsearch $ifaces $iid_top] |
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID] |
|
|
|
set iid_top $IID |
|
set iface ::p::ifaces::>$iid_top |
|
} |
|
} |
|
} |
|
|
|
$iface . open |
|
return $iid_top |
|
} |
|
|
|
|
|
|
|
|
|
|
|
dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}} |
|
proc ::p::-1::Properties {_ID_ {idx ""}} { |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces |
|
|
|
set col ::p::${OID}::_meta::>colProperties |
|
|
|
if {[namespace which $col] eq ""} { |
|
patternlib::>collection .. Create $col |
|
foreach IID $ifaces { |
|
dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] { |
|
if {![$col . hasIndex $prop]} { |
|
$col . add [::p::internals::predator $_ID_ . $prop .] $prop |
|
} |
|
} |
|
} |
|
} |
|
|
|
if {[string length $idx]} { |
|
return [$col . item $idx] |
|
} else { |
|
return $col |
|
} |
|
} |
|
|
|
dict set ::p::-1::_iface::o_methods P {arglist {}} |
|
proc ::p::-1::P {_ID_} { |
|
set invocants [dict get $_ID_ i] |
|
set this_invocant [lindex [dict get $invocants this] 0] |
|
lassign $this_invocant OID _etc |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces |
|
|
|
set members [list] |
|
foreach IID $interfaces { |
|
foreach prop [dict keys [set ::p::${IID}::_iface::o_properties]] { |
|
lappend members $prop |
|
} |
|
} |
|
return [lsort $members] |
|
|
|
} |
|
#Interface Properties |
|
dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}} |
|
proc ::p::-1::IP {_ID_ {glob *}} { |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces |
|
set members [list] |
|
|
|
foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { |
|
if {[string match $glob [lindex $m 0]]} { |
|
lappend members [lindex $m 0] |
|
} |
|
} |
|
return $members |
|
} |
|
|
|
|
|
#used by rename.test - theoretically should be on a separate interface! |
|
dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}} |
|
proc ::p::-1::CheckInvocants {_ID_ args} { |
|
#check all invocants in the _ID_ are consistent with data stored in their MAP variable |
|
set status "ok" ;#default to optimistic assumption |
|
set problems [list] |
|
|
|
set invocant_dict [dict get $_ID_ i] |
|
set invocant_roles [dict keys $invocant_dict] |
|
|
|
foreach role $invocant_roles { |
|
set invocant_list [dict get $invocant_dict $role] |
|
foreach aliased_invocantdata $invocant_list { |
|
set OID [lindex $aliased_invocantdata 0] |
|
set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] |
|
#we use lrange to make sure the lists are in canonical form |
|
if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { |
|
set status "not-ok" |
|
lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] |
|
} |
|
} |
|
|
|
} |
|
|
|
|
|
set result [dict create] |
|
dict set result status $status |
|
dict set result problems $problems |
|
|
|
return $result |
|
} |
|
|
|
|
|
#get or set t |
|
dict set ::p::-1::_iface::o_methods Namespace {arglist {args}} |
|
proc ::p::-1::Namespace {_ID_ args} { |
|
#set invocants [dict get $_ID_ i] |
|
#set this_invocant [lindex [dict get $invocants this] 0] |
|
#lassign $this_invocant OID this_info |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
set IID [lindex [dict get $MAP interfaces level0] end] |
|
|
|
namespace upvar ::p::${IID}::_iface o_varspace active_varspace |
|
|
|
if {[string length $active_varspace]} { |
|
set ns ::p::${OID}::$active_varspace |
|
} else { |
|
set ns ::p::${OID} |
|
} |
|
|
|
#!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object? |
|
# - should .. Namespace be usable at all from outside the object? |
|
|
|
|
|
if {[llength $args]} { |
|
#special case some of the namespace subcommands. |
|
|
|
#delete |
|
if {[string match "d*" [lindex $args 0]]} { |
|
error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object." |
|
} |
|
#upvar,ensemble,which,code,origin,expor,import,forget |
|
if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} { |
|
return [namespace eval $ns [list namespace {*}$args]] |
|
} |
|
#current |
|
if {[string match "cu*" [lindex $args 0]]} { |
|
return $ns |
|
} |
|
|
|
#children,eval,exists,inscope,parent,qualifiers,tail |
|
return [namespace {*}[linsert $args 1 $ns]] |
|
} else { |
|
return $ns |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}} |
|
proc ::p::-1::PatternUnknown {_ID_ args} { |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
set patterns [dict get $MAP interfaces level1] |
|
set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. |
|
|
|
if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { |
|
#remove ourself from the usedby list of the previous interface |
|
array unset ::p::${existing_IID}::_iface::o_usedby i$OID |
|
set ::p::${IID}::_iface::o_usedby(i$OID) $cmd |
|
|
|
set posn [lsearch $patterns $existing_IID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] |
|
#::p::predator::remap $invocant |
|
} |
|
|
|
set handlermethod [lindex $args 0] |
|
|
|
|
|
if {[llength $args]} { |
|
set ::p::${IID}::_iface::o_unknown $handlermethod |
|
return |
|
} else { |
|
set ::p::${IID}::_iface::o_unknown $handlermethod |
|
} |
|
|
|
} |
|
|
|
|
|
|
|
dict set ::p::-1::_iface::o_methods Unknown {arglist {args}} |
|
proc ::p::-1::Unknown {_ID_ args} { |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
set interfaces [dict get $MAP interfaces level0] |
|
set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. |
|
|
|
set prev_open [set ::p::${existing_IID}::_iface::o_open] |
|
|
|
if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { |
|
#remove ourself from the usedby list of the previous interface |
|
array unset ::p::${existing_IID}::_iface::o_usedby i$OID |
|
set ::p::${IID}::_iface::o_usedby(i$OID) $cmd |
|
|
|
set posn [lsearch $interfaces $existing_IID] |
|
|
|
set extracted_sub_dict [dict get $MAP interfaces] |
|
dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] |
|
dict set MAP interfaces $extracted_sub_dict |
|
#lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] |
|
|
|
set ::p::${IID}::_iface::o_open 0 |
|
} else { |
|
set ::p::${IID}::_iface::o_open $prev_open |
|
} |
|
|
|
set handlermethod [lindex $args 0] |
|
|
|
if {[llength $args]} { |
|
set ::p::${IID}::_iface::o_unknown $handlermethod |
|
#set ::p::${IID}::(unknown) $handlermethod |
|
|
|
|
|
#interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod |
|
interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod |
|
interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod |
|
|
|
#namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod] |
|
#namespace eval ::p::${OID} [list namespace unknown $handlermethod] |
|
|
|
return |
|
} else { |
|
set ::p::${IID}::_iface::o_unknown $handlermethod |
|
} |
|
|
|
} |
|
|
|
|
|
#useful on commandline - can just uparrow and add to it to become '<previous cmd> .. As varname' instead of editing start and end of commandline to make it 'set varname [<previous cmd>]' |
|
# should also work for non-object results |
|
dict set ::p::-1::_iface::o_methods As {arglist {varname}} |
|
proc ::p::-1::As {_ID_ varname} { |
|
set invocants [dict get $_ID_ i] |
|
#puts stdout "invocants: $invocants" |
|
#!todo - handle multiple invocants with other roles, not just 'this' |
|
|
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
if {$OID ne "null"} { |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
tailcall set $varname $cmd |
|
} else { |
|
#puts stdout "info level 1 [info level 1]" |
|
set role_members [dict get $_ID_ i this] |
|
if {[llength $role_members] == 1} { |
|
set member [lindex $role_members 0] |
|
lassign $member _OID namespace default_method stackvalue _wrapped |
|
tailcall set $varname $stackvalue |
|
} else { |
|
#multiple invocants - return all results as a list |
|
set resultlist [list] |
|
foreach member $role_members { |
|
lassign $member _OID namespace default_method stackvalue _wrapped |
|
lappend resultlist $stackvalue |
|
} |
|
tailcall set $varname $resultlist |
|
} |
|
} |
|
} |
|
|
|
#!todo - AsFileStream ?? |
|
dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}} |
|
proc ::p::-1::AsFile {_ID_ filename args} { |
|
dict set default -force 0 |
|
dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object |
|
set opts [dict merge $default $args] |
|
set force [dict get $opts -force] |
|
set dumpmethod [dict get $opts -dumpmethod] |
|
|
|
|
|
if {[file pathtype $filename] eq "relative"} { |
|
set filename [pwd]/$filename |
|
} |
|
set filedir [file dirname $filename] |
|
if {![sf::file_writable $filedir]} { |
|
error "(method AsFile) ERROR folder $filedir is not writable" |
|
} |
|
if {[file exists $filename]} { |
|
if {!$force} { |
|
error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite" |
|
} |
|
if {![sf::file_writable $filename]} { |
|
error "(method AsFile) ERROR file $filename is not writable - check permissions" |
|
} |
|
} |
|
set fd [open $filename w] |
|
fconfigure $fd -translation binary |
|
|
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
if {$OID ne "null"} { |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
#tailcall set $varname $cmd |
|
set object_data [$cmd {*}$dumpmethod] |
|
puts -nonewline $fd $object_data |
|
close $fd |
|
return [list status 1 bytes [string length $object_data] filename $filename] |
|
} else { |
|
#puts stdout "info level 1 [info level 1]" |
|
set role_members [dict get $_ID_ i this] |
|
if {[llength $role_members] == 1} { |
|
set member [lindex $role_members 0] |
|
lassign $member _OID namespace default_method stackvalue _wrapped |
|
puts -nonewline $fd $stackvalue |
|
close $fd |
|
#tailcall set $varname $stackvalue |
|
return [list status 1 bytes [string length $stackvalue] filename $filename] |
|
} else { |
|
#multiple invocants - return all results as a list |
|
set resultlist [list] |
|
foreach member $role_members { |
|
lassign $member _OID namespace default_method stackvalue _wrapped |
|
lappend resultlist $stackvalue |
|
} |
|
puts -nonewline $fd $resultset |
|
close $fd |
|
return [list status 1 bytes [string length $resultset] filename $filename] |
|
#tailcall set $varname $resultlist |
|
} |
|
} |
|
|
|
} |
|
|
|
|
|
|
|
dict set ::p::-1::_iface::o_methods Object {arglist {}} |
|
proc ::p::-1::Object {_ID_} { |
|
set invocants [dict get $_ID_ i] |
|
set OID [lindex [dict get $invocants this] 0 0] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
|
|
set result [string map [list ::> ::] $cmd] |
|
if {![catch {info level -1} prev_level]} { |
|
set called_by "(called by: $prev_level)" |
|
} else { |
|
set called_by "(called by: interp?)" |
|
|
|
} |
|
|
|
puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" |
|
puts stdout " (returning $result)" |
|
|
|
return $result |
|
} |
|
|
|
#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname |
|
dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} |
|
proc ::p::-1::MakeAlias {_ID_cmdname } { |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
lassign [dict get $MAP invocantdata] OID alias itemCmd cmd |
|
|
|
error "concept probably won't work - try making dispatcher understand trailing '= cmdname' " |
|
} |
|
dict set ::p::-1::_iface::o_methods ID {arglist {}} |
|
proc ::p::-1::ID {_ID_} { |
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
|
return $OID |
|
} |
|
|
|
dict set ::p::-1::_iface::o_methods IFINFO {arglist {}} |
|
proc ::p::-1::IFINFO {_ID_} { |
|
puts stderr "--_ID_: $_ID_--" |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
puts stderr "-- MAP: $MAP--" |
|
|
|
set interfaces [dict get $MAP interfaces level0] |
|
set IFID [lindex $interfaces 0] |
|
|
|
if {![llength $interfaces]} { |
|
puts stderr "No interfaces present at level 0" |
|
} else { |
|
foreach IFID $interfaces { |
|
set iface ::p::ifaces::>$IFID |
|
puts stderr "$iface : [$iface --]" |
|
puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" |
|
set variables [set ::p::${IFID}::_iface::o_variables] |
|
puts stderr "\tvariables: $variables" |
|
} |
|
} |
|
|
|
} |
|
|
|
|
|
|
|
|
|
dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} |
|
proc ::p::-1::INVOCANTDATA {_ID_} { |
|
#same as a call to: >object .. |
|
return $_ID_ |
|
} |
|
|
|
#obsolete? |
|
dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}} |
|
proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} { |
|
set updated_ID_ $_ID_ |
|
array set updated_roles [list] |
|
|
|
set invocants [dict get $_ID_ i] |
|
set invocant_roles [dict keys $invocants] |
|
foreach role $invocant_roles { |
|
|
|
set role_members [dict get $invocants $role] |
|
foreach member [dict get $invocants $role] { |
|
#each member is a 2-element list consisting of the OID and a dictionary |
|
#each member is a 5-element list |
|
#set OID [lindex $member 0] |
|
#set object_dict [lindex $member 1] |
|
lassign $member OID alias itemcmd cmd wrapped |
|
|
|
set MAP [set ::p::${OID}::_meta::map] |
|
#if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} |
|
|
|
if {[dict get $MAP invocantdata] eq $member} |
|
#same - nothing to do |
|
|
|
} else { |
|
package require overtype |
|
puts stderr "---------------------------------------------------------" |
|
puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" |
|
set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] |
|
puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" |
|
puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" |
|
puts stderr "---------------------------------------------------------" |
|
#take _meta::map version |
|
lappend updated_roles($role) [dict get $MAP invocantdata] |
|
} |
|
|
|
} |
|
|
|
#overwrite changed roles only |
|
foreach role [array names updated_roles] { |
|
dict set updated_ID_ i $role [set updated_roles($role)] |
|
} |
|
|
|
return $updated_ID_ |
|
} |
|
|
|
|
|
|
|
dict set ::p::-1::_iface::o_methods INFO {arglist {}} |
|
proc ::p::-1::INFO {_ID_} { |
|
set result "" |
|
append result "_ID_: $_ID_\n" |
|
|
|
set invocants [dict get $_ID_ i] |
|
set invocant_roles [dict keys $invocants] |
|
append result "invocant roles: $invocant_roles\n" |
|
set total_invocants 0 |
|
foreach key $invocant_roles { |
|
incr total_invocants [llength [dict get $invocants $key]] |
|
} |
|
|
|
append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" |
|
foreach key $invocant_roles { |
|
append result "\t-------------------------------\n" |
|
append result "\trole: $key\n" |
|
set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants |
|
append result "\t Raw data for this role: $role_members\n" |
|
append result "\t Number of invocants in this role: [llength $role_members]\n" |
|
foreach member $role_members { |
|
#set OID [lindex [dict get $invocants $key] 0 0] |
|
set OID [lindex $member 0] |
|
append result "\t\tOID: $OID\n" |
|
if {$OID ne "null"} { |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
append result "\t\tmap:\n" |
|
foreach key [dict keys $MAP] { |
|
append result "\t\t\t$key\n" |
|
append result "\t\t\t\t [dict get $MAP $key]\n" |
|
append result "\t\t\t----\n" |
|
} |
|
lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped |
|
append result "\t\tNamespace: $namespace\n" |
|
append result "\t\tDefault method: $default_method\n" |
|
append result "\t\tCommand: $cmd\n" |
|
append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n" |
|
append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n" |
|
append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n" |
|
} else { |
|
lassign $member _OID namespace default_method stackvalue _wrapped |
|
append result "\t\t last item on the predator stack is a value not an object" |
|
append result "\t\t Value is: $stackvalue" |
|
|
|
} |
|
} |
|
append result "\n" |
|
append result "\t-------------------------------\n" |
|
} |
|
|
|
|
|
|
|
return $result |
|
} |
|
|
|
|
|
|
|
|
|
dict set ::p::-1::_iface::o_methods Rename {arglist {args}} |
|
proc ::p::-1::Rename {_ID_ args} { |
|
set OID [::p::obj_get_this_oid $_ID_] |
|
if {![llength $args]} { |
|
error "Rename expected \$newname argument" |
|
} |
|
|
|
#Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant? |
|
upvar #0 ::p::${OID}::_meta::map MAP |
|
|
|
|
|
|
|
#puts ">>.>> Rename. _ID_: $_ID_" |
|
|
|
if {[catch { |
|
|
|
if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { |
|
|
|
#appears to be a 'trace command rename' firing |
|
#puts "\t>>>> rename trace fired $MAP $args <<<" |
|
|
|
lassign $args oldcmd newcmd |
|
set extracted_invocantdata [dict get $MAP invocantdata] |
|
lset extracted_invocantdata 3 $newcmd |
|
dict set MAP invocantdata $extracted_invocantdata |
|
|
|
|
|
lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped |
|
|
|
#Write the same info into the _ID_ value of the alias |
|
interp alias {} $alias {} ;#first we must delete it |
|
interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] |
|
|
|
|
|
|
|
#! $object_command was initially created as the renamed alias - so we have to do it again |
|
uplevel 1 [list rename $alias $object_command] |
|
trace add command $object_command rename [list $object_command .. Rename] |
|
|
|
} elseif {[llength $args] == 1} { |
|
#let the rename trace fire and we will be called again to do the remap! |
|
uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] |
|
} else { |
|
error "Rename expected \$newname argument ." |
|
} |
|
|
|
} errM]} { |
|
puts stderr "\t@@@@@@ rename error" |
|
set ruler "\t[string repeat - 80]" |
|
puts stderr $ruler |
|
puts stderr $errM |
|
puts stderr $ruler |
|
|
|
} |
|
|
|
return |
|
|
|
|
|
} |
|
|
|
proc ::p::obj_get_invocants {_ID_} { |
|
return [dict get $_ID_ i] |
|
} |
|
#The invocant role 'this' is special and should always have only one member. |
|
# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX |
|
proc ::p::obj_get_this_oid {_ID_} { |
|
return [lindex [dict get $_ID_ i this] 0 0] |
|
} |
|
proc ::p::obj_get_this_ns {_ID_} { |
|
return [lindex [dict get $_ID_ i this] 0 1] |
|
} |
|
|
|
proc ::p::obj_get_this_cmd {_ID_} { |
|
return [lindex [dict get $_ID_ i this] 0 3] |
|
} |
|
proc ::p::obj_get_this_data {_ID_} { |
|
lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd |
|
#set this_invocant_data {*}[dict get $_ID_ i this] |
|
return [list oid $OID ns $ns cmd $cmd] |
|
} |
|
proc ::p::map {OID varname} { |
|
tailcall upvar #0 ::p::${OID}::_meta::map $varname |
|
} |
|
|
|
|
|
|
|
|