diff --git a/src/bootsupport/modules/include_modules.config b/src/bootsupport/modules/include_modules.config index edd7393d..3a8e96a7 100644 --- a/src/bootsupport/modules/include_modules.config +++ b/src/bootsupport/modules/include_modules.config @@ -23,6 +23,7 @@ set bootsupport_modules [list\ src/vendormodules patterncmd\ src/vendormodules patternlib\ src/vendormodules patternpredator2\ + src/vendormodules patterncipher\ src/vendormodules promise\ src/vendormodules sha1\ src/vendormodules tomlish\ @@ -50,7 +51,7 @@ set bootsupport_modules [list\ modules punk::ansi\ modules punk::assertion\ modules punk::args\ - modules punk::args::tclcore\ + modules punk::args::moduledoc::tclcore\ modules punk::cap\ modules punk::cap::handlers::caphandler\ modules punk::cap::handlers::scriptlibs\ diff --git a/src/bootsupport/modules/metaface-1.2.8.tm b/src/bootsupport/modules/metaface-1.2.8.tm index 39a54c8c..c216b1df 100644 --- a/src/bootsupport/modules/metaface-1.2.8.tm +++ b/src/bootsupport/modules/metaface-1.2.8.tm @@ -1,44 +1,44 @@ package require dictutils package provide metaface [namespace eval metaface { variable version - set version 1.2.8 + set version 1.2.8 }] # 2025-09-29 - update outdated 'trace vinfo' to 'trace info variable' - both work for 8.6, but vinfo deprecated for tcl 9+ -# 2023-07 - add .. MetaMethods +# 2023-07 - add .. MetaMethods #example datastructure: #$_ID_ #{ -#i -# { -# this -# { -# {16 ::p::16 item ::>x {}} -# } -# role2 -# { -# {17 ::p::17 item ::>y {}} -# {18 ::p::18 item ::>z {}} -# } -# } +#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 {} -# } +#invocantdata {16 ::p::16 item ::>x {}} +#interfaces {level0 +# { +# api0 {stack {123 999}} +# api1 {stack {333}} +# } +# level0_default api0 +# level1 +# { +# } +# level1_default {} +# } #patterndata {patterndefaultmethod {}} @@ -105,7 +105,7 @@ proc ::p::predator::getprop_template_immediate {_ID_ args} { 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'! + #don't assume defaultmethod named 'item'! return [$val {*}$args] } else { #treat as list? @@ -127,60 +127,60 @@ proc ::p::predator::getprop_template_immediate {_ID_ args} { 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 + #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]] - } - } + 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]] + } + } } #-------------------------------------- @@ -189,7 +189,7 @@ proc ::p::predator::setprop_template {prop _ID_ args} { 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. @@ -210,7 +210,7 @@ proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtrace set $refname $newval } } - return + return } } @@ -218,80 +218,80 @@ proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtrace 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} + #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 + 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 - } + #!quick n dirty + #error $errorMsg + return -code error -errorinfo $::errorInfo $result + } else { + return $result + } } @@ -301,7 +301,7 @@ proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname id 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_] @@ -311,7 +311,7 @@ proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { array set $refname {} } - #return value ignored for + #return value ignored for } @@ -319,7 +319,7 @@ proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { # 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 + lassign [dict get $MAP invocantdata] OID alias itemCmd #don't rely on variable name passed by trace - may have been 'upvar'ed @@ -334,7 +334,7 @@ proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { #!todo - get propertylist from cache on object(?) foreach IFID [lreverse $iflist] { dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { - #lassign $pdef v + #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}] @@ -346,419 +346,395 @@ proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { } } } - array set $refvar $plist + 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" - } -} + 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 + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd - 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] { + #!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" - } - } + } + + 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] { + 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 + #$IID is now topmost interface in default iStack which has this property - if {[string length $IID]} { - #write to defined 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 - } - } + ::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] - - + #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 + } + } - #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 - } - } - @@ -768,676 +744,653 @@ proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtrace 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" - - } - + 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] + 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 info variable $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]" + #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 info variable $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 } } - - #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 @@ -1457,9 +1410,9 @@ proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { # -#returns 0 if method implementation not present for interface +#returns 0 if method implementation not present for interface proc ::p::predator::method_chainhead {iid method} { - #Interface proc + #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] @@ -1483,7 +1436,7 @@ proc ::p::predator::method_chainhead {iid method} { -#this returns a script that upvars vars for all interfaces on the calling object - +#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] @@ -1491,16 +1444,16 @@ proc ::p::predator::upvar_all {_ID_} { ::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] { + ::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] { + ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { ::set varspace [::dict get $vinfo varspace] ::lappend nsvars($varspace) $vname } @@ -1511,33 +1464,33 @@ proc ::p::predator::upvar_all {_ID_} { ::set ns ::p::${OID} } else { if {[::string match "::*" $varspace]} { - ::set ns $varspace + ::set ns $varspace } else { ::set ns ::p::${OID}::$varspace } } - ::append decl "namespace upvar $ns " + ::append decl "namespace upvar $ns " ::foreach vname [::set nsvars($varspace)] { ::append decl "$vname $vname " } - ::append decl " ;\n" + ::append decl " ;\n" } ::array unset nsvars - } - } - ::return $decl + } + } + ::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 + 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 } @@ -1547,103 +1500,103 @@ proc ::p::predator::runtime_vardecls {} { #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" + 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 { + # foreach vdef $o_variables { # append varDecls "[lindex $vdef 0] [lindex $vdef 0] " - # } - # append varDecls \n - #} + # } + # 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,*] {} - #runtime gathering of vars from other interfaces. - #append varDecls [runtime_vardecls] - set varDecls [runtime_vardecls] + #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. - - #implement methods - #!todo - avoid globs on iface array? maintain list of methods in another slot? - #foreach {n mname} [array get IFACE m-1,name,*] {} + #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] - #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 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 next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? - - set body $IFACE(pw,body,$property) - + 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]]} { + + 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 [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}] - #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}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body + interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid - set maxversion [::p::predator::method_chainhead $IFID $property] - set headid [expr {$maxversion + 1}] + #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body + } + } + #'unset' overrides - proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body + dict for {property handler_info} $o_propertyunset_handlers { - 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 + set body [dict get $handler_info body] + set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array - 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 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 THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? @@ -1660,31 +1613,31 @@ proc ::p::predator::compile_interface {IFID caller_ID_} { } 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] + #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 - } + #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. + + 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@). @@ -1694,7 +1647,7 @@ proc ::p::predator::compile_interface {IFID caller_ID_} { set body [set ::p::${IFID}::_iface::o_destructor_body] - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + 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)} { @@ -1707,23 +1660,23 @@ proc ::p::predator::compile_interface {IFID caller_ID_} { #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] + #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 + 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 + return } @@ -1736,7 +1689,7 @@ proc ::p::predator::compile_interface {IFID caller_ID_} { 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]] } @@ -1757,11 +1710,11 @@ proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { set i 0 foreach arg [lrange $nextArgs 1 end] { upvar 1 $arg $i - if {$arg eq "args"} { + 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] } @@ -1779,11 +1732,11 @@ 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 + #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. - + # .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 . @@ -1799,8 +1752,8 @@ proc ::p::predator::next_script {IFID method caller caller_ID_} { } 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 - + #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}] @@ -1837,8 +1790,8 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { 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 + #(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 @@ -1848,17 +1801,17 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { #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 @@ -1866,33 +1819,33 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { 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.. + #!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"} { + if {$arg eq "args"} { #need to check if 'args' is actually available in caller if {[info exists $i]} { - set argVals [concat $argVals [set $i]] - } + set argVals [concat $argVals [set $i]] + } } else { lappend argVals [set $i] } @@ -1911,7 +1864,7 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args } } - #no interfaces in the iStack contained a matching method. + #no interfaces in the iStack contained a matching method. return } else { #no further interfaces in this iStack @@ -1923,43 +1876,42 @@ proc ::p::predator::do_next_if {_ID_ IFID method args} { #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' (((" + #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] + #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 - } + #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 + } } @@ -1984,28 +1936,28 @@ proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { #!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 - + #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 _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_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? + #'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] @@ -2030,51 +1982,51 @@ 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 +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 {} + } - 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 + 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 --] + #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 - lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd - - #Merge lastmodified(?) level0 and level1 interfaces. - - } + #Merge lastmodified(?) level0 and level1 interfaces. + + } return $target } @@ -2087,70 +2039,67 @@ proc ::p::-1::Concatenate {_ID_ target args} { 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 + 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 - 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 + #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 + #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] - } + #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] + } } @@ -2159,44 +2108,44 @@ 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] + + 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]]} { + + 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" - } + } 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] + 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 + #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] + #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] } @@ -2206,64 +2155,64 @@ proc ::p::-1::Construct {_ID_ argpairs body 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 - } - - #-------------- + #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 - - #-------------- + 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]" - - + #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 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 + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + return $child } -#configure -prop1 val1 -prop2 val2 ... +#configure -prop1 val1 -prop2 val2 ... dict set ::p::-1::_iface::o_methods Configure {arglist args} proc ::p::-1::Configure {_ID_ args} { @@ -2272,7 +2221,7 @@ proc ::p::-1::Configure {_ID_ args} { ::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'" } @@ -2286,7 +2235,7 @@ proc ::p::-1::Configure {_ID_ args} { lappend properties_to_configure [string range $argprop 1 end] } - #gather all valid property names for all level0 interfaces in the relevant interface stack + #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] { @@ -2323,59 +2272,59 @@ proc ::p::-1::Configure {_ID_ args} { 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" - } +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 + - 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? + #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 + 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 +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" + } - 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] + 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] } @@ -2395,7 +2344,7 @@ proc ::p::-1::AddInterface {_ID_ iid} { #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}} +# >somepattern .. Create {>child {-id 1}} #or # >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] #complex form - with arguments to the contructor: @@ -2409,12 +2358,12 @@ proc ::p::-1::Create {_ID_ target_spec args} { } 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 <<<" @@ -2422,9 +2371,7 @@ proc ::p::-1::Create {_ID_ target_spec 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" @@ -2433,15 +2380,15 @@ proc ::p::-1::Create {_ID_ target_spec args} { #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 + 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 - + set IFID0 [lindex $interfaces 0] + set IFID1 [lindex $patterns 0] ;#1st pattern + #upvar ::p::${OID}:: INFO if {![string match {::*} $child]} { @@ -2456,14 +2403,14 @@ proc ::p::-1::Create {_ID_ target_spec args} { #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] @@ -2471,7 +2418,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { 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] @@ -2487,20 +2434,20 @@ proc ::p::-1::Create {_ID_ target_spec args} { #--------- #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] + 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 @@ -2512,40 +2459,38 @@ proc ::p::-1::Create {_ID_ target_spec args} { } 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 + # 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 + #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] + # #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 @@ -2562,16 +2507,16 @@ proc ::p::-1::Create {_ID_ target_spec args} { #puts " **** CHILDMAP: $CHILDMAP" #puts " ****" - #puts stderr " ---> Properties: [$child .. Properties . names]" - #puts stderr " ---> Methods: [$child .. Properties . names]" - + #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] + #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 + # 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 @@ -2604,17 +2549,17 @@ proc ::p::-1::Create {_ID_ target_spec args} { #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] + 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. @@ -2683,7 +2628,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { 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_ @@ -2691,8 +2636,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { } } - - + package require struct::set set propcmds [list] @@ -2707,8 +2651,8 @@ proc ::p::-1::Create {_ID_ target_spec args} { #$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 + 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] @@ -2735,7 +2679,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { } else { set a $argspec } - + if {$a eq "args"} { append argvals " \{*\}\$args" } else { @@ -2743,29 +2687,27 @@ proc ::p::-1::Create {_ID_ target_spec args} { } } 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 + + #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@ + # ::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 @@ -2788,23 +2730,23 @@ proc ::p::-1::Create {_ID_ target_spec args} { } #! 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}::$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 + 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 - # } - # } + # 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]} { @@ -2822,16 +2764,15 @@ proc ::p::-1::Create {_ID_ target_spec args} { 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 ""} { @@ -2846,13 +2787,12 @@ proc ::p::-1::Create {_ID_ target_spec args} { } } } - + 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 + 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] } @@ -2861,9 +2801,9 @@ proc ::p::-1::Create {_ID_ target_spec args} { if {$constructor_failure} { if {$is_new_object} { #is Destroy enough to ensure that no new interfaces or objects were left dangling? - $child .. Destroy + $child .. Destroy } else { - #object needs to be returned to a sensible state.. + #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. @@ -2880,10 +2820,10 @@ proc ::p::-1::Create {_ID_ target_spec args} { #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. - + # - 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" @@ -2895,7 +2835,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { 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 + set present 0 } if {[array exists $vname]} { @@ -2904,7 +2844,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { array set $target [array get $vname] } else { if {[array exists $target]} { - #unset superfluous elements + #unset superfluous elements foreach key [array names $target] { if {$key ni [array names $vname]} { array unset $target $key @@ -2930,7 +2870,7 @@ proc ::p::-1::Create {_ID_ target_spec args} { if {[array exists $target]} { #target has been changed to array - unset it and recreate the simple variable. unset $target - set $target [set $vname] + set $target [set $vname] } else { if {[set $target] ne [set $vname]} { set $target [set $vname] @@ -2950,12 +2890,10 @@ proc ::p::-1::Create {_ID_ target_spec args} { return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error } namespace delete $ns_snap - - } - - - return $child + } + + return $child } dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} @@ -2969,8 +2907,8 @@ proc ::p::-1::Clone {_ID_ clone args} { 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] + set _cmd [string map {::> ::} $cmd] + set tail [namespace tail $_cmd] #obsolete? @@ -2989,17 +2927,17 @@ proc ::p::-1::Clone {_ID_ clone args} { } - set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] - set _clone [string map {::> ::} $clone] + set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] + set _clone [string map {::> ::} $clone] - set cTail [namespace tail $_clone] + set cTail [namespace tail $_clone] set ns [namespace qualifiers $clone] if {$ns eq ""} { set ns "::" } - + namespace eval $ns {} @@ -3014,7 +2952,7 @@ proc ::p::-1::Clone {_ID_ clone args} { 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] @@ -3029,18 +2967,18 @@ proc ::p::-1::Clone {_ID_ clone args} { #! 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] + 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 + #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 clone_INFO [array get INFO] array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' @@ -3056,28 +2994,28 @@ proc ::p::-1::Clone {_ID_ clone args} { #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 + #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 [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. + + #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. + #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 } } @@ -3117,10 +3055,10 @@ proc ::p::-1::Clone {_ID_ clone args} { #! 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}::$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 + 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 @@ -3144,18 +3082,18 @@ proc ::p::-1::Clone {_ID_ clone args} { #update the clone object's base interface to reflect the new methods. - #upvar 0 ::p::${ifid}:: IFACE + #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 + # 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 { @@ -3164,7 +3102,7 @@ proc ::p::-1::Clone {_ID_ clone args} { } else { set a $argspec } - + if {$a eq "args"} { append argvals " \{*\}\$args" } else { @@ -3172,10 +3110,9 @@ proc ::p::-1::Clone {_ID_ clone args} { } } 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 + #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?) @@ -3183,15 +3120,15 @@ proc ::p::-1::Clone {_ID_ clone args} { 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 + 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] @@ -3213,12 +3150,12 @@ proc ::p::-1::Clone {_ID_ clone args} { # 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 + # 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 + # 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 + # #!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. @@ -3226,14 +3163,14 @@ proc ::p::-1::Clone {_ID_ clone args} { #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 - + } @@ -3241,77 +3178,77 @@ proc ::p::-1::Clone {_ID_ clone args} { 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 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 + 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] - 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]] + #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] + 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 + #::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 + # 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 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]] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + 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" - } + } 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] + #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 ---- + #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 + 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 + set o_constructor [list $arglist $body] + set o_open 1 + + return } @@ -3340,246 +3277,245 @@ proc ::p::-1::Destroy {_ID_ {force 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 - } + 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 + 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 - 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 + + 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 + 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 - + #::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 - #} + #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] { + # 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 + #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] { + 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 {[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 {} + if {$force} { + #rename $cmd {} - #removing the alias will remove the command - even if it's been renamed - interp alias {} $alias {} + #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!!!!!!!!!!" - #} + #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" - 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 {} + #} - #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}::*]]" - #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 "- 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}]" - #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 - #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 + #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout + return } @@ -3593,44 +3529,44 @@ 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 + #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 } @@ -3645,7 +3581,7 @@ 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 @@ -3667,12 +3603,12 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { # 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 THISNAME $method.$headid ;#first version will be $method.1 - set next [::p::predator::next_script $IID $method $THISNAME $_ID_] + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + 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)} { @@ -3690,11 +3626,11 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { 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] + #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 $body #puts "\n" #puts "\t\t--------------------" proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body @@ -3706,7 +3642,7 @@ proc ::p::-1::PatternMethod {_ID_ method arglist body} { - if {$method in [dict keys $o_methods]} { + 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]} { @@ -3732,15 +3668,15 @@ proc ::p::-1::PatternMethod {_ID_ method 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? +# - 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? +# - 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} { +proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { set invocants [dict get $_ID_ i] error "not implemented" @@ -3750,45 +3686,45 @@ dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsu # 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 +#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 - } +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 - } +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 + } } @@ -3801,7 +3737,7 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { 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. + ;# 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]] } @@ -3816,11 +3752,11 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { ################################################################################# if 0 { - set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface + 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 @@ -3837,25 +3773,25 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { 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 + #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 + #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] @@ -3866,10 +3802,10 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { #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]]} { + #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 @@ -3877,97 +3813,93 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { } 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] - } + } 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] - #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--------------------------" - #} + #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. + # 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] + #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 - - + 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 {} @@ -3977,37 +3909,37 @@ proc ::p::-1::Method {_ID_ method arglist bodydef args} { } - #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + #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 + #::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 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 + 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 + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set vlist [list] + set vlist [list] foreach IID $ifaces { dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { if {[string match $glob $vname]} { @@ -4015,8 +3947,6 @@ proc ::p::-1::V {_ID_ {glob *}} { } } } - - return $vlist } @@ -4036,105 +3966,100 @@ proc p::predator::pipeline {args} { } 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] + 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 + #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 +#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]} { + #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 " - - - } + } 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 " + + } } @@ -4145,67 +4070,67 @@ proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist #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' +#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 {} + set body {} - #keep count of any explicit var statments per varspace in 'numDeclared' array + #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] + 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 + 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) + 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]])} { + #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} " + #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\] " + 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} " + } 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]] - + #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 "" } @@ -4213,7 +4138,7 @@ proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { #set varspace ::${varspace}:: #no need to initialize numDeclared($varspace) incr will work anyway. #if {![info exists numDeclared($varspace)]} { - # set numDeclared($varspace) 0 + # set numDeclared($varspace) 0 #} if {[string match "::*" $varspace]} { @@ -4229,13 +4154,13 @@ proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { #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 - } - } + #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] @@ -4244,7 +4169,7 @@ proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { -#Interface Variables +#Interface Variables dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} proc ::p::-1::IV {_ID_ {glob *}} { set invocants [dict get $_ID_ i] @@ -4258,16 +4183,16 @@ proc ::p::-1::IV {_ID_ {glob *}} { #!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 + 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 MetaMethods {arglist {{glob *}}} +dict set ::p::-1::_iface::o_methods MetaMethods {arglist {{glob *}}} proc ::p::-1::MetaMethods {_ID_ {glob *}} { upvar ::p::-1::_iface::o_methods metaface_methods set metamethod_names [lsort [dict keys $metaface_methods]] @@ -4286,7 +4211,7 @@ proc ::p::-1::Methods {_ID_ {idx ""}} { #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 @@ -4305,11 +4230,11 @@ proc ::p::-1::Methods {_ID_ {idx ""}} { } } } - if {[string length $idx]} { - return [$col . item $idx] - } else { - return $col - } + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } } dict set ::p::-1::_iface::o_methods M {arglist {{glob *}}} @@ -4320,13 +4245,13 @@ proc ::p::-1::M {_ID_ {glob *}} { #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 + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set members [list] + set members [list] foreach IID $ifaces { lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob] } - return $members + return $members } #PatternMethods @@ -4337,13 +4262,13 @@ proc ::p::-1::PM {_ID_ {glob *}} { 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 itemCmd cmd + #lassign [dict get $MAP invocantdata] OID alias itemCmd cmd set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces - set members [list] + set members [list] foreach IID $ifaces { lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob] } - return [lsort $members] + return [lsort $members] } @@ -4358,10 +4283,10 @@ proc ::p::-1::IM {_ID_ {glob *}} { 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 + 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] + return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] } @@ -4369,70 +4294,70 @@ proc ::p::-1::IM {_ID_ {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] + 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] + 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 +#!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] + 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] + 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] } @@ -4441,18 +4366,18 @@ 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 + + set result [dict create] + dict set result {*}[$this .. DeletePropertyReferences] + dict set result {*}[$this .. DeleteMethodReferences] + + return $result } ## #Digest # -#!todo - review +#!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 @@ -4469,7 +4394,7 @@ proc ::p::-1::Digest {_ID_ args} { 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] @@ -4478,15 +4403,14 @@ proc ::p::-1::Digest {_ID_ args} { 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" @@ -4494,9 +4418,9 @@ proc ::p::-1::Digest {_ID_ args} { 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 + # i.e set x 34; set y 5 # must be distinguishable from: - # set x 3; set y 45 + # set x 3; set y 45 if {[dict get $opts -indent] ne ""} { set state "" @@ -4507,13 +4431,11 @@ proc ::p::-1::Digest {_ID_ args} { } 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" @@ -4528,7 +4450,7 @@ proc ::p::-1::Digest {_ID_ args} { } } } - + append state "${indent}vars:\n" foreach var [info vars ::p::${OID}::*] { append state "${indent} - [namespace tail $var] : \"" @@ -4545,7 +4467,7 @@ proc ::p::-1::Digest {_ID_ args} { 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 " @@ -4556,8 +4478,7 @@ proc ::p::-1::Digest {_ID_ args} { } } } - - + if {$algo in {"" raw none}} { return $state } else { @@ -4574,13 +4495,13 @@ proc ::p::-1::Digest {_ID_ args} { >b1 . encrypt $state -final 1 set result [>b1 . ciphertext] >b1 .. Destroy - + } elseif {$algo eq "blowfish-binary"} { - + } else { error "can't get here" } - + } } @@ -4629,12 +4550,12 @@ proc ::p::-1::Variable {_ID_ varname 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] + # set ::p::${OID}::${varspace}::$varname [lindex $args 0] #} else { set ::p::${OID}::$varname [lindex $args 0] #} @@ -4653,45 +4574,45 @@ proc ::p::-1::Variable {_ID_ varname args} { 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 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 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 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 + 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] + 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 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. + 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] - } + 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 + return } dict set ::p::-1::_iface::o_methods Varspaces {arglist args} @@ -4701,7 +4622,7 @@ proc ::p::-1::Varspaces {_ID_ args} { upvar #0 ::p::${OID}::_meta::map MAP if {![llength $args]} { - #query + #query set iid_top [lindex [dict get $MAP interfaces level0] end] set iface ::p::ifaces::>$iid_top if {![string length $iid_top]} { @@ -4717,7 +4638,7 @@ proc ::p::-1::Varspaces {_ID_ args} { set varspaces $args foreach vs $varspaces { if {[string length $vs] && ($vs ni $o_varspaces)} { - if {[string match ::* $vs} { + if {[string match ::* $vs]} { namespace eval $vs {} } else { namespace eval ::p::${OID}::$vs {} @@ -4725,7 +4646,7 @@ proc ::p::-1::Varspaces {_ID_ args} { lappend o_varspaces $vs } } - return $o_varspaces + 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 @@ -4737,7 +4658,7 @@ proc ::p::-1::Varspace {_ID_ args} { ::p::map $OID MAP if {![llength $args]} { - #query + #query set iid_top [lindex [dict get $MAP interfaces level0] end] set iface ::p::ifaces::>$iid_top if {![string length $iid_top]} { @@ -4775,7 +4696,7 @@ proc ::p::-1::Varspace {_ID_ args} { 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 + upvar #0 ::p::${OID}::_meta::map MAP set interfaces [dict get $MAP interfaces level0] set iid_top [lindex $interfaces end] @@ -4786,7 +4707,7 @@ proc ::p::predator::get_possibly_new_open_interface {OID} { 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 @@ -4811,73 +4732,72 @@ 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 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 + 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] - 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 + 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 + 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 } @@ -4885,7 +4805,7 @@ 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]} { @@ -4913,7 +4833,7 @@ proc ::p::-1::GetTopInterface {_ID_ args} { dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} proc ::p::-1::GetExpandableInterface {_ID_ args} { - + } @@ -4946,7 +4866,7 @@ proc ::p::-1::Property {_ID_ property args} { #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 @@ -4959,27 +4879,27 @@ proc ::p::-1::Property {_ID_ property args} { 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 + 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} + # set ns ::p::${OID} #} else { - # if {[string match "::*" $o_varspace]} { - # set ns $o_varspace - # } else { - # set ns ::p::${OID}::$o_varspace - # } + # 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]] @@ -4987,56 +4907,56 @@ proc ::p::-1::Property {_ID_ property args} { #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 + #installation on object - #namespace eval ::p::${OID} [list namespace export $property] + #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 - #} + #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 + 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 - #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] - #} + #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] @@ -5051,10 +4971,10 @@ proc ::p::-1::Property {_ID_ property args} { 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]] + # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] #} else { - # lappend o_properties [list $property $default] - #} + # lappend o_properties [list $property $default] + #} if {$varspace eq ""} { set ns ::p::${OID} @@ -5065,16 +4985,16 @@ proc ::p::-1::Property {_ID_ property args} { 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]] + # set o_properties [lreplace $o_properties $posn $posn [list $property]] #} else { - # lappend o_properties [list $property] - #} + # lappend o_properties [list $property] + #} dict set o_properties $property [list varspace $varspace] @@ -5085,18 +5005,18 @@ proc ::p::-1::Property {_ID_ property args} { - #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} - + #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 + + return } ################################################################################################################################################### @@ -5131,7 +5051,7 @@ proc ::p::-1::PatternProperty {_ID_ property args} { 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 + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 @@ -5141,12 +5061,12 @@ proc ::p::-1::PatternProperty {_ID_ property args} { 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]])} { @@ -5158,15 +5078,15 @@ proc ::p::-1::PatternProperty {_ID_ property args} { #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] + # set o_variables [lreplace $o_variables $posn $posn o_$property] #} else { - # lappend o_variables [list o_$property] + # lappend o_variables [list o_$property] #} dict set o_variables o_$property [list varspace $varspace] set argc [llength $args] - if {$argc} { + if {$argc} { if {$argc == 1} { set default [lindex $args 0] dict set o_properties $property [list default $default varspace $varspace] @@ -5210,93 +5130,93 @@ proc ::p::-1::PatternProperty {_ID_ property args} { ################################################################################################################################################### 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 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\"" + } + - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] + 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 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\"" - } + 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 + } - 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}] + 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 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_ - + 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 + #----------------------------------- - #implement - #----------------------------------- - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + 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] + } 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 - } + #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 + #adjust chain-head pointer to point to new head. + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + return } ################################################################################################################################################### @@ -5318,7 +5238,7 @@ 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 @@ -5351,7 +5271,7 @@ proc ::p::-1::PropertyRead {_ID_ property args} { } 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] @@ -5367,7 +5287,7 @@ proc ::p::-1::PropertyRead {_ID_ property args} { 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]]} { @@ -5381,12 +5301,12 @@ proc ::p::-1::PropertyRead {_ID_ property args} { 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] + #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 - #----------------------------------- + #----------------------------------- @@ -5396,7 +5316,7 @@ proc ::p::-1::PropertyRead {_ID_ property args} { 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 + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property } } ################################################################################################################################################### @@ -5424,69 +5344,69 @@ proc ::p::-1::PropertyWrite {_ID_ property argname body} { 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. - + 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 - 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 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 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 - } + 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] + #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_] + 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 + #----------------------------------- - #implement - #----------------------------------- - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + 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] + } 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 + 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 + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid } ################################################################################################################################################### @@ -5508,40 +5428,38 @@ proc ::p::-1::PropertyWrite {_ID_ property argname body} { ################################################################################################################################################### 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 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. + 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] + 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 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 existing_ifaces [lindex $map 1 1] + set posn [lsearch $existing_ifaces $existing_IID] - #set ::p::${IID}::_iface::o_open 0 - } else { - } + 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] - #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] + #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 + return } ################################################################################################################################################### @@ -5557,69 +5475,69 @@ proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { ################################################################################################################################################### 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 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. - 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 - 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 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 - } + 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] + 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 maxversion [::p::predator::method_chainhead $IID (UNSET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (UNSET)$property.$headid + set THISNAME (UNSET)$property.$headid - set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] + 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]]} { + 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] + } 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 + #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 +#pointer from method-name to head of override-chain +interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid } ################################################################################################################################################### @@ -5636,34 +5554,34 @@ proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { ################################################################################################################################################### 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 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. + 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] - 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 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 + } - 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] + upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] - return + return } ################################################################################################################################################### @@ -5680,31 +5598,30 @@ proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { #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 + 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 + 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 } @@ -5714,7 +5631,7 @@ proc ::p::-1::Extend {_ID_ {idx ""}} { tailcall ::p::-1::Expand $_ID_ $idx } -#set the topmost interface on the iStack to be 'open' +#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] @@ -5723,7 +5640,7 @@ proc ::p::-1::Expand {_ID_ {idx ""}} { 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 @@ -5735,7 +5652,7 @@ proc ::p::-1::Expand {_ID_ {idx ""}} { return $iid_top } else { if {[$iface . isOpen]} { - #already open.. + #already open.. #assume ready to expand.. shared or not! return $iid_top } @@ -5744,21 +5661,21 @@ proc ::p::-1::Expand {_ID_ {idx ""}} { 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] + + #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 + set iface ::p::ifaces::>$iid_top } } } @@ -5783,7 +5700,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { ::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 @@ -5800,7 +5717,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { return $iid_top } else { if {[$iface . isOpen]} { - #already open.. + #already open.. #assume ready to expand.. shared or not! return $iid_top } @@ -5811,7 +5728,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { #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] @@ -5820,7 +5737,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { set iid_top $IID set iface ::p::ifaces::>$iid_top - } + } } } @@ -5834,7 +5751,7 @@ proc ::p::-1::PatternExpand {_ID_ {idx ""}} { 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] + 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 @@ -5867,11 +5784,11 @@ proc ::p::-1::P {_ID_ {glob *}} { upvar #0 ::p::${OID}::_meta::map MAP set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set members [list] + set members [list] foreach IID $interfaces { lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob] } - return [lsort $members] + return [lsort $members] } #PatternProperties @@ -5884,11 +5801,11 @@ proc ::p::-1::PP {_ID_ {glob *}} { upvar #0 ::p::${OID}::_meta::map MAP set interfaces [dict get $MAP interfaces level1] ;#level 1 interfaces - set members [list] + set members [list] foreach IID $interfaces { lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob] } - return [lsort $members] + return [lsort $members] } @@ -5896,71 +5813,71 @@ proc ::p::-1::PP {_ID_ {glob *}} { #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 + 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 + #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} - } + #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? @@ -6003,33 +5920,33 @@ 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 - } + 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 + } } @@ -6041,58 +5958,58 @@ proc ::p::-1::Unknown {_ID_ args} { 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] + 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 + 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 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 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 ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_open + } - set handlermethod [lindex $args 0] + set handlermethod [lindex $args 0] - if {[llength $args]} { - set ::p::${IID}::_iface::o_unknown $handlermethod - #set ::p::${IID}::(unknown) $handlermethod + 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 + #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 - } + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } } #useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []' -# should also work for non-object results +# 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 @@ -6143,8 +6060,8 @@ proc ::p::-1::AsFile {_ID_ filename args} { } } set fd [open $filename w] - fconfigure $fd -translation binary - + fconfigure $fd -translation binary + set invocants [dict get $_ID_ i] set OID [lindex [dict get $_ID_ i this] 0 0] if {$OID ne "null"} { @@ -6178,7 +6095,7 @@ proc ::p::-1::AsFile {_ID_ filename args} { #tailcall set $varname $resultlist } } - + } @@ -6190,58 +6107,58 @@ proc ::p::-1::Object {_ID_} { 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?)" + 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)" + 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 + return $result } #todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname -dict set ::p::-1::_iface::o_methods MakeAlias {arglist {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 + 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" - } - } - + 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" + } + } + } @@ -6249,81 +6166,81 @@ proc ::p::-1::IFINFO {_ID_} { dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} proc ::p::-1::INVOCANTDATA {_ID_} { - #same as a call to: >object .. - return $_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_ + 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] + 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 @@ -6344,16 +6261,16 @@ proc ::p::-1::INFO {_ID_} { 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 + } + append result "\n" + append result "\t-------------------------------\n" + } + + + + return $result } @@ -6371,52 +6288,52 @@ proc ::p::-1::Rename {_ID_ args} { - #puts ">>.>> Rename. _ID_: $_ID_" + #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 <<<" - if {[catch { + lassign $args oldcmd newcmd + set extracted_invocantdata [dict get $MAP invocantdata] + lset extracted_invocantdata 3 $newcmd + dict set MAP invocantdata $extracted_invocantdata - 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 - - 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 {}] - #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 - - } + #! $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 - return - } proc ::p::obj_get_invocants {_ID_} { diff --git a/src/bootsupport/modules/patterncipher-0.1.1.tm b/src/bootsupport/modules/patterncipher-0.1.1.tm new file mode 100644 index 00000000..62b03cbc --- /dev/null +++ b/src/bootsupport/modules/patterncipher-0.1.1.tm @@ -0,0 +1,1459 @@ +#JMN 2021 +#public domain + + +#--------------------------------------------------------- +#todo - see if we can include twofish https://wiki.tcl-lang.org/page/Twofish+in+Tcl +# - that twofish implementation relies on Itcl. todo - create .tm package for it. (change oo system?) +#--------------------------------------------------------- +# +# encryption decryption howto + +# patternciper::>AES .. Create >obj +# set [>obj . cipherkey .] $16bytes +# >obj . encrypt $arbitray_data_of_any_length +# (returns number of bytes stored) +# +# >obj . encrypt $any_size_string -last 1 +# (the -last flag will make the encryption system pad the last chunk) +# >obj . ciphertext .. As my_encrypted_data_variable +# set checkplaintext [>obj . decrypt] +# (this can be used to verify decryption and resets the cbc encryption ready for another round) +# +# + + +package provide patterncipher [namespace eval patterncipher { + variable version + set version 0.1.1 +}] + + + +#Change History +#------------------------------------------------------------------------------- +# 2021 - start out with blowfish as although it's outdated, it's easily available in tcllib. Todo - add twofish, AES +#------------------------------------------------------------------------------- + +package require ascii85 ;#tcllib +package require pattern +::pattern::init ;# initialises (if not already) + +namespace eval ::patterncipher { + namespace eval algo::txt { + set tokenid 0 + set tokendata [dict create] + set data_block_bytes 0 ;#means don't care + set iv_bytes 16 + set key_byte_sizes [list 8 16] + + + proc Init {mode keydata iv} { + variable tokenid + variable tokendata + if {[string length $iv] != 16} { + error "[namespace::current] Init IV must be 16 bytes long" + } + + dict set tokendata $tokenid [list mode $mode key $keydata iv $iv lastblock "" ] + return [lindex [list [namespace current]::$tokenid [incr tokenid]] 0] ;#post increment via inline K combinator + } + proc Encrypt {token data} { + variable tokendata + variable data_block_bytes + set tokenid [namespace tail $token] + if {![dict exists $tokendata $tokenid]} { + error "([namespace current]::Encrypt) invalid tokenid $tokenid token:$token" + } + if {$data_block_bytes != 0} { + if {([string length $data] % $data_block_bytes) != 0} { + error "([namespace current]::Encrypt) invalid block size for data. Must be $data_block_bytes bytes." + } + set idx [expr {$data_block_bytes - 1}] + dict set tokendata $tokenid lastblock [string range $data end-$idx end] + } + set client_mode [dict get $tokendata $tokenid mode] + set iv_as_mode [string trim [dict get $tokendata $tokenid iv] _] + + + + if {$iv_as_mode ne $client_mode} { + set enc [encoding convertto $iv_as_mode [encoding convertfrom $client_mode $data]] + } else { + set enc [encoding convertfrom $client_mode $data] + } + + return $enc + } + proc Decrypt {token data} { + variable tokendata + set tokenid [namespace tail $token] + if {![dict exists $tokendata $tokenid]} { + error "([namespace current]::Decrypt) invalid tokenid $tokenid token:$token" + } + set client_mode [dict get $tokendata $tokenid mode] + set iv_mode [string trim [dict get $tokendata $tokenid iv] _] + + if {$iv_mode ne $client_mode} { + set dec [encoding convertfrom $iv_mode $data] + } else { + set dec $data + } + set dec [encoding convertto $client_mode $dec] + + return $dec + } + proc Reset {token iv} { + variable tokendata + set tokenid [namespace tail $token] + if {![dict exists $tokendata $tokenid]} { + error "([namespace current]::Reset) invalid tokenid $tokenid token:$token" + } + dict set tokendata $tokenid lastblock "" + + } + proc Final {token} { + variable tokendata + set tokenid [namespace tail $token] + if {![dict exists $tokendata $tokenid]} { + error "([namespace current]::Final) invalid tokenid $tokenid token:$token" + } + dict unset tokendata $tokenid + } + } + +} + +namespace eval ::patterncipher { + #namespace export {[a-z]*} + #namespace export {[>]*} + proc help {} { + set cipherlib ::patterncipher::libs::>lib_standard + set definitions [$cipherlib . cipher_definitions] + set m "" + append m "\n" + append m "Create cipher-specific objects with name of your choosing for encryption and decryption:\n" + + foreach cn [$cipherlib . ciphernames] { + append m "patterncipher::>$cn .. Create >my-[dict get $definitions $cn cipherid]-encryptor\n" + } + + append m "\n" + append m "--------------------------------------------------------------------------------------------------\n" + append m "Get cipher specific help e.g patterncipher::>blowfish, patterncipher::>AES etc :\n" + append m "patterncipher::>AES . help ;#patterncipher::>AES is the prototype from which we create objects.\n" + append m " ;# The prototype itself has a help method which is not inherited by objects created from it\n" + } + + + + namespace eval libs {} ;#namespace for >lib instances + + + patternlib::>collection .. Create >libs + + >pattern .. Create >lib + >lib .. Method help {} { + set help { + To create a custom library: +::patterncipher::>lib .. Create ::patterncipher::libs::>my-lib -name "mylib" .. As mylib + or +set mylib [::patterncipher::>lib .. Create ::patterncipher::libs::>my-lib -name "mylib"] + + The object will automatically be added to the collection ::patterncipher::>libs + The latest element added to this collection will be the one used by new cipher instances. + To create a cipher using a specific >lib instance, use -patterncipherlib when constructing instances + + } + return $help + } + + >lib .. PatternProperty name + >lib .. PatternPropertyWrite name {newname} { + var o_name + if {$o_name eq "standard"} { + #!todo - allow -force option in case caller knows what they're doing? + error "(>lib-instance . name (write)) ERROR: cannot rename 'standard' library." + } + ::patterncipher::>libs . reKey $o_name $newname + set o_name $newname + } + + >lib .. Constructor {args} { + var this o_name o_padding_schemes o_bucketsize_by_hex1 o_ascii85_wraplen + var o_frame_boundaries o_hex1_by_bucketsize o_bucketsize_by_hex4 o_hex4_by_bucketsize + var o_cipher_definitions o_cipherids + set this @this@ + #---------------------------------------------------------------------------- + set known_opts [list -name] + dict set default -name "" + if {([llength $args] % 2) != 0} { + error "(>lib-instance .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((>lib-instance .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set o_name [dict get $opts -name] + #---------------------------------------------------------------------------- + if {![string length $o_name]} { + error "((>lib-instance .. Constructor) ERROR: -name value is required." + } + + if {[::patterncipher::>libs . hasKey $o_name]} { + error "((>lib-instance .. Constructor) ERROR: -name value is already in the ::patterncipher::>libs collection - choose another name." + } + + ::patterncipher::>libs . add ::patterncipher::libs::>lib_standard $o_name ;# now avail as '::patterncipher::>libs $o_name' + + #Once the standard lib is in the collection, overlay a >keayvalprotector on >libs to stop the standard lib being removed too easily + if {$o_name eq "standard"} { + ::patternlib::>keyvalprotector .. Create ::patterncipher::>libs -keys [list standard] -vals [list $this] + } + + #----------------------------------------------------------------------------------------------------- + #set up stream chunk boundaries + #64 bytes selected as the smallest chunk size. Obfuscates lengths for small pieces of data - plus 5Byte header overhead not too bad. + ## starting data - redistributed + ##set block1 [list 512 512 512 512 512 512 512 512] + ##set block2 [list 1024 1024 1024 1024] + ##set block3 [list 2048 2048] + set block1 [list 64 192 320 448 576 704 832 960 ] ; #128 spacing + set block2 [list 976 1008 1040 1072] ;# 32 spacing + set block3 [list 1984 2112] ;#128 spacing + set block4 [list 4096] + # 4096 4096 4096 ... repeated until final chunk detected. + #This gives 15 values. Hex 1 to F, leaving 0 for the final arbitrary length rest-of-stream. + # ie 64 = 1 192 = 2 ... 1040 = B 4096 = F + + #If the blocks above are played with - streaming incompatibilities/inefficiences will occur with previous/other versions of patterncipher. + set code_check 1 + if $code_check { + set o_frame_boundaries [concat $block1 $block2 $block3 $block4] + foreach l [list $block1 $block2 $block3 ] { + if {[expr [join $l +]] != 4096} { + error "frame_boundaries list is not configured as a 4096 multiple" + } + } + if {![expr [join $o_frame_boundaries +]] == 16384} { + #This boundary sequence that should be a multiple of 4K. + error "frame_boundaries list is not configured as a 4096 multiple" + } + foreach len $o_frame_boundaries { + if {($len % 8) != 0} { + error "stream boundary '$len' is not a multiple of 8 bytes" + } + } + } + #set up bucketids + set bucket_hex4 [list] + foreach len $o_frame_boundaries { + lappend bucket_hex4 [format %04x $len] ;# e.g 192 = 00c0 4096 = 1000 + } + + set o_bucketsize_by_hex1 [concat {*}[lmap c {1 2 3 4 5 6 7 8 9 A B C D E F} s $o_frame_boundaries {list $c $s}]] ;#dict + set o_bucketsize_by_hex4 [concat {*}[lmap h $bucket_hex4 s $o_frame_boundaries {list $h $s}]] ;#dict + + set o_hex1_by_bucketsize [concat {*}[lmap s $o_frame_boundaries c {1 2 3 4 5 6 7 8 9 A B C D E F} {list $s $c}]] ;#dict + set o_hex4_by_bucketsize [concat {*}[lmap s $o_frame_boundaries h $bucket_hex4 {list $s $h}]] ;#dict + + + set o_padding_schemes [list 0 text-minpad 1 text-buckets 2 binary-minpad 3 binary-buckets] + #whichever padding_scheme is used, the frame_boundaries will still be used to determine where to split the data + set o_ascii85_wraplen 120 + + + #------------------ + #For cipherid "TXT" + #pull out desired default encoding and put it at the front of the list + set encnames [encoding names] + set default "utf-8" ;#must be one that's in the list + set idx [lsearch $encnames $default] + set encnames [lreplace $encnames $idx $idx] + set encnames [concat $default $encnames] + #------------------ + + #---------------------------------------------------- + #iv_static should only be 1 for testing, or for specific definitions such as 'TXT' which use IV to carry the text encoding hint. + # + #notes: + #- always list the default mode first in modes + #- iv_method is a method with arguments of the patterncipher library. + # New methods can be grafted onto the lib as necessary. + # The argument %ivb will be substituted with iv_bytes value + # The argument %cn will be substituted with the key used in o_cipher_definitions + # (this could then be used in a method to retrieve any of the other defined values) + # The iv_method must be able to handle -userdata user-supplied IV data (or empty string if none). + # Can be verified/ignored etc. + #- cipherid must be 3 bytes long and is used in the default header building mechanism + # !todo - add a member such as 'hdr_method' to allow the lib to define a totally different header system. + #- pkgrequire & algocommand together define the underlying encryption library command. + # This must provide the API as used by various tcllib encryption functions such as AES & blowfish + # A custom algocommand e.g some commands placed in '::patterncipher::algo::' may be able to wrap other + # libraries/functionalities if the semantics are not too dissimilar. + # The API used by the tcllib encryption functions has commands: Init,Encrypt,Decrypt,Reset,Final. + # + set o_cipher_definitions [dict create] + dict set o_cipher_definitions "text" [list \ + enabled 1\ + cipherid "TXT" \ + pkgrequire patterncipher\ + algocommand ::patterncipher::algo::txt\ + data_block_bytes 0\ + iv_bytes 16\ + iv_static 1\ + iv_method [list get_iv_for_ciphername %cn]\ + key_byte_sizes [list 8]\ + modes $encnames\ + ] + + dict set o_cipher_definitions "blowfish" [list \ + enabled 1\ + cipherid "BFS" \ + pkgrequire blowfish\ + algocommand ::blowfish\ + data_block_bytes 8\ + iv_bytes 8\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic ]\ + key_byte_sizes [list 8]\ + modes [list cbc ecb]\ + ] + + dict set o_cipher_definitions "AES" [list \ + enabled 1\ + cipherid "AES"\ + pkgrequire aes\ + algocommand ::aes\ + data_block_bytes 16\ + iv_bytes 16\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 16 24 32]\ + modes [list cbc ecb]\ + ] + dict set o_cipher_definitions "AES-128" [list \ + enabled 1\ + cipherid "A16"\ + pkgrequire aes\ + algocommand ::aes\ + data_block_bytes 16\ + iv_bytes 16\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 16]\ + modes [list cbc ecb]\ + ] + dict set o_cipher_definitions "AES-192" [list \ + enabled 1\ + cipherid "A24"\ + pkgrequire aes\ + algocommand ::aes\ + data_block_bytes 16\ + iv_bytes 16\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 24]\ + modes [list cbc ecb]\ + ] + dict set o_cipher_definitions "AES-256" [list \ + enabled 1\ + cipherid "A32"\ + pkgrequire aes\ + algocommand ::aes\ + data_block_bytes 16\ + iv_bytes 16\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 32]\ + modes [list cbc ecb]\ + ] + dict set o_cipher_definitions "DES" [list \ + enabled 1\ + cipherid "DES"\ + pkgrequire des\ + algocommand ::DES\ + data_block_bytes 8\ + iv_bytes 8\ + iv_static 0\ + iv_method [list get_random_bytes %ivb -method basic]\ + key_byte_sizes [list 8 32]\ + modes [list cbc ecb cfb ofb]\ + ] + + $this . rebuild_cipher_ids_and_names + + puts stdout "padding_buckets hex1code: $o_bucketsize_by_hex1" + puts stdout "padding_buckets hex4code: $o_bucketsize_by_hex4" + #----------------------------------------------------------------------------------------------------- + } + + >lib .. PatternMethod cipher_disable {ciphername} { + var this o_cipher_definitions + if {$ciphername ni [dict keys $o_cipher_definitions]} { + error "(>lib . cipher_disable) ciphername $ciphername not in list of defined ciphers: [dict keys $o_cipher_definitions]" + } + dict set o_cipher_definitions $ciphername enabled 0 + $this . rebuild_cipher_ids_and_names + return 1 + } + + >lib .. PatternMethod cipher_enable {ciphername} { + var o_cipher_definitions + if {$ciphername ni [dict keys $o_cipher_definitions]} { + error "(>lib . cipher_enable) ciphername $ciphername not in list of defined ciphers: [dict keys $o_cipher_definitions]" + } + dict set o_cipher_definitions $ciphername enabled 1 + $this . rebuild_cipher_ids_and_names + return 1 + } + >lib .. PatternMethod rebuild_cipher_ids_and_names {} { + var o_cipherids o_ciphernames o_cipher_definitions + set o_cipherids [list] + set o_ciphernames [list] + foreach k [dict keys $o_cipher_definitions] { + if {[dict get $o_cipher_definitions $k enabled]} { + lappend o_cipherids [dict get $o_cipher_definitions $k cipherid] + lappend o_ciphernames $k + } + } + return $o_cipherids + } + + >lib .. PatternProperty cipher_definitions [dict create] + + #the cipherids must be 3 bytes - to form part of the ciphertexts 8byte header. e.g BFS = blowfish has headers like 1BFSC42E + >lib .. PatternProperty cipherids [list] + >lib .. PatternProperty ciphernames [list] + + >lib .. PatternProperty padding_schemes + >lib .. PatternProperty ascii85_wraplen + + >lib .. PatternProperty frame_boundaries + >lib .. PatternPropertyWrite frame_boundaries {boundarylist} { + var o_name o_frame_boundaries + if {$o_name eq "standard"} { + error "(>lib-instance . frame_boundaries (write)) ERROR: frame_boundaries is read-only. Create a new patterncipher::>lib object for different behaviour" + } + set o_frame_boundaries $boundarylist + } + >lib .. PatternProperty hex1_by_bucketsize + >lib .. PatternPropertyWrite hex1_by_bucketsize {newval} { + #calculated from $o_frame_boundaries - never needs to be writable + error "(>lib-instance . hex1_by_bucketsize (write)) ERROR: hex1_by_bucketsize is read-only." + } + >lib .. PatternProperty bucketsize_by_hex1 + >lib .. PatternPropertyWrite bucketsize_by_hex1 {newval} { + #calculated from $o_frame_boundaries - never needs to be writable + error "(>lib-instance . bucketsize_by_hex1 (write)) ERROR: hex1_by_bucketsize is read-only." + } + + >lib .. PatternProperty hex4_by_bucketsize + >lib .. PatternPropertyWrite hex4_by_bucketsize {newval} { + #calculated from $o_frame_boundaries - never needs to be writable + error "(>lib-instance . hex4_by_bucketsize (write)) ERROR: hex4_by_bucketsize is read-only." + } + >lib .. PatternProperty bucketsize_by_hex4 + >lib .. PatternPropertyWrite bucketsize_by_hex4 {newval} { + #calculated from $o_frame_boundaries - never needs to be writable + error "(>lib-instance . bucketsize_by_hex4 (write)) ERROR: hex4_by_bucketsize is read-only." + } + + #K can be used by some cipher_definitions to set the iv to a string - alternatively - lindex [list "value" _dontcare] 0 + #also it is known as the K combinator + >lib .. PatternMethod K {a args} {set a} + + + >lib .. PatternMethod get_iv_for_ciphername {cname args} { + #any specific customizations we need to get an IV for a specific cipher + var this o_cipher_definitions + #---------------------------------------------------------------------------- + set known_args [list -userdata] + if {([llength $args] % 2) != 0} { + error "(get_iv_for_ciphername) ERROR: odd number of options supplied. Usage: '. get_iv_for_ciphername \$ciphername \[-option val\]*' where -option one of '$known_args' " + } + if {[llength $args]} { + foreach {a b} $args { + if {$a ni $known_args} { + error "(get_random_bytes) ERROR: unknown option '$a'. Usage: '. get_iv_for_ciphername \$ciphername \[-option val\]*' where -option one of '$known_args' " + } + } + } + dict set default -userdata "" + set opts [dict merge $default $args] + set userdata [dict get $opts -userdata] + #---------------------------------------------------------------------------- + + + set ivb [dict get $o_cipher_definitions $cname iv_bytes] + switch $cname { + "text" { + if {![string length $userdata]} { + set m [lindex [dict get $o_cipher_definitions $cname modes] 0] + if {![string length $m]} { + error "($this get_iv_for_ciphername) Error: can't calculate IV" + } + set iv "$m[string repeat _ $ivb]" + set iv [string range $iv 0 $ivb-1] + # e.g "utf-8___________" + return $iv + } else { + if {[string length $userdata] == $ivb} { + #assume they know what they're doing if length exactly right and pass through as is + return $userdata + } else { + #It's valid to supply an encoding name such as utf-8 or unicode - check that the system knows it first though + if {$userdata in [dict get $o_cipher_definitions $cname modes]} { + set iv "$userdata[string repeat _ $ivb]" + return [string range $iv 0 $ivb-1] + } else { + error "($this get_iv_for_ciphername) Error: can't calculate IV from user supplied data '$userdata'" + } + } + } + } + default { + return [$this . get_random_bytes $ivb -userdata $userdata] + } + } + } + + >lib .. PatternVariable o_get_random_bytes_calls 0 ;#additional data for random seed values - ensure no two calls have same seed even if called in quick succession. + >lib .. PatternMethod get_random_bytes {len args} { + var o_get_random_bytes_calls + incr o_get_random_bytes_calls + #puts stdout "get_random_bytes call:$o_get_random_bytes_calls" + + #---------------------------------------------------------------------------- + set known_args [list -method -ascii85 -userdata] + if {([llength $args] % 2) != 0} { + error "(get_random_bytes) ERROR: odd number of options supplied. Usage: '. get_random_bytes \$numbytes \[-option val\]*' where -option one of '$known_args' " + } + if {[llength $args]} { + foreach {a b} $args { + if {$a ni $known_args} { + error "(get_random_bytes) ERROR: unknown option '$a'. Usage: '. get_random_bytes \$numbytes \[-option val\]*' where -option one of '$known_args' " + } + } + } + dict set default -method basic + dict set default -ascii85 0 + dict set default -userdata "" + set opts [dict merge $default $args] + set method [dict get $opts -method] + set ascii85 [dict get $opts -ascii85] + set userdata [dict get $opts -userdata] + #---------------------------------------------------------------------------- + + + set known_methods [list basic] + switch [string tolower $method] { + "basic" { + #considered cryptographically insecure. + #pick $len numbers 0 to 255 + set seed [clock seconds] + append seed [clock clicks] $o_get_random_bytes_calls [pid] + #!todo - add some unpredictable things to the seed. + expr {srand($seed)} ;#srand seems to be able to handle artibrarily large numbers + set bytelist [list] + for {set i 0} {$i < $len} {incr i} { + lappend bytelist [expr {int(rand()*256)}] ;# 0 to 255 + } + #puts stdout ">>bytelist $bytelist" + if {$ascii85} { + #Note. Do not wrap here. (e.g do not use o_ascii85_wraplen). Manually do it later so linebreaks in final result are consistent. + # - also, ascii85::encode uses regular expressions where maxlen can't be > 256 + set random_binstr [binary format c$len $bytelist] + #always truncate to proper length before encoding.. + set combined [string range $userdata$random_binstr 0 $len-1] + + set text [ascii85::encode -maxlen 0 $combined] + return [string range $text 0 $len-1] ;#truncate again in case it grew + } else { + + set random_binstr [binary format c${len} $bytelist] + + return [string range $userdata$random_binstr 0 $len-1] + } + } + default { + error "(get_random_bytes) ERROR: Unknown randomisation method '$method'. Expected one of '$known_methods'" + } + } + } + >lib .. PatternMethod get_bucket_info {size_of_ascii85} { + var o_frame_boundaries o_hex1_by_bucketsize o_hex4_by_bucketsize + set hex1 F ;#default if no other code matched - means 'Final' and payload limit of 4080 + set hex4 00 ;#Final - and payload limit of 65535 + set size 0 ;#indicates unspecified/unlimited + foreach bucketsize $o_frame_boundaries { + if {$size_of_ascii85 < $bucketsize} { + set hex1 [dict get $o_hex1_by_bucketsize $bucketsize] + set hex4 [dict get $o_hex4_by_bucketsize $bucketsize] + set size $bucketsize + break + } + } + puts stdout "... get_bucket_info [list hex1 $hex1 hex4 $hex4 size $size]" + return [list hex1 $hex1 hex4 $hex4 size $size] + } + >lib .. Create ::patterncipher::libs::>lib_standard -name "standard" + +} + + +namespace eval ::patterncipher { + +#--------------------------------------------------------------------------- + #overlay/mixin - (created in constructor) these also become properties on the >blowfish/>aes instances + # - + # - These are cipher-specific settings not intended to be user configurable. + >pattern .. Create >cipher_bytesizes + >cipher_bytesizes .. Constructor {args} { + var this o_data_block_bytes o_iv_bytes o_key_byte_sizes o_spud + set this @this@ + puts stdout "---->cipher_bytesizes Constructor running with args $args creating $this" + #---------------------------------------------------------------------------- + set known_opts [list] + set required_opts [list] + set default [dict create] + #dict set default -something etc + if {([llength $args] % 2) != 0} { + error "($this . Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "(($this . Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + foreach o $required_opts { + if {$o ni $args} { + error "(($this . Constructor) ERROR: the following options are not actually optional: '$required_opts'" + } + } + set opts [dict merge $default $args] + #---------------------------------------------------------------------------- + + } + #Hidden - variables with PropertyRead and/or PropertyWrite become a hidden property + # readonly & hidden + >cipher_bytesizes .. PatternVariable o_data_block_bytes + >cipher_bytesizes .. PatternPropertyRead data_block_bytes {} { + var o_data_block_bytes + return $o_data_block_bytes + } + + #readonly & hidden + >cipher_bytesizes .. PatternVariable o_iv_bytes + >cipher_bytesizes .. PatternPropertyRead iv_bytes {} { + var o_iv_bytes + return $o_iv_bytes + } + + #readonly and visible + >cipher_bytesizes .. PatternProperty key_byte_sizes + >cipher_bytesizes .. PatternPropertyWrite key_byte_sizes {not_writable} { + var this + error "($this . key_byte_sizes (write)) ERROR: property key_byte_sizes is read only." + } + + #--------------------------------------------------------------------------- + + + +} + + +namespace eval ::patterncipher { + + + #mixin via Clone mechanism to the >cipher prototype + ::patterncipher::>cipher_bytesizes .. Clone [namespace current]::>ciphermaster + + + >ciphermaster .. Construct {} { + var this + set this @this@ + } + >ciphermaster .. Method help {} { + var this o_ciphername + set this @this@ + #o_data_block_bytes o_iv_bytes o_key_byte_sizes + set cipherlib ::patterncipher::libs::>lib_standard + set cipherdefs [$cipherlib . cipher_definitions] + set key_byte_sizes [dict get $cipherdefs $o_ciphername key_byte_sizes] + set data_block_bytes [dict get $cipherdefs $o_ciphername data_block_bytes] + + #a sample key of correct length for first key size in $key_byte_sizes + set longkey "8BYTES1\]8BYTES2\]8BYTES3\]8BYTES4\]8BYTES5\]8BYTES6\]8BYTES7\]8BYTES8\]" + set keysample [string range $longkey 0 [lindex $key_byte_sizes 0]-1] + + set help { + + patterncipher::>object .. Create >b1 + set [>b1 . key .] %kb1 ;#encipherment key. Allowed number of bytes: '%kbs%' + >b1 . encrypt \$something ;#chunks added don't have to be multiple of %dbs% bytes + >b1 . encrypt \"some-data-123\" ;# - they will be buffered,concatenated and finally padded. + >b1 . encrypt "\[command yielding data\]" -last 1 ;# '. encrypt -last 1' can take empty string if needed + ;# - alternatively you can call '. encryptlast' or '. encryptlast $lastchunk' instead + set encrypted_data [>b1 . ciphertext] ;# defaults to hex encoded + set raw_encrypted_data [>b1 . ciphertext -raw 1] ;# binary output + set verify [>b1 . decrypt_and_reset] ;# Only after calling this ( or '. reset' ) + ;# - can we start a new encrypting/decrypting cycle + + -------------------------------------------------------------------------------------------------------- + #To decrypt: + set [>b1 . ciphertext .] $encrypted_data ;# expects hex encoded, with 8-char header e.g '0BFS0FFF' + set plaintext [>b1 . decrypt_and_reset] + + } + set help [string map [list ">object" >$o_ciphername ">b1" >${o_ciphername}-instance %kb1 $keysample %kbs% $key_byte_sizes %dbs% $data_block_bytes] $help] + } + + + >ciphermaster .. Constructor {args} { + var this o_patterncipherlib o_ciphername + set this @this@ + puts stdout "(>cipher $this .. Constructor) running with args $args creating $this vars:[info vars]" + #---------------------------------------------------------------------------- + set known_opts [list -patterncipherlib] + dict set default -patterncipherlib [::patterncipher::>libs -1 ] ;#last item added to the >libs collection + if {([llength $args] % 2) != 0} { + error "(>cipher $this .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((>cipher $this .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set o_patterncipherlib [dict get $opts -patterncipherlib] + #---------------------------------------------------------------------------- + + $this . _init_cipher_from_definitions $o_ciphername + #set [$this . ciphername .] $o_ciphername + + + #run the next constructor (from object cloned onto this one) + #var o_data_block_bytes o_iv_bytes o_key_byte_sizes + puts stderr ">>>>>> here <<<" + #@next@ -data_block_bytes $o_data_block_bytes -iv_bytes $o_iv_bytes -key_byte_sizes $o_key_byte_sizes + #mixin + #$this .. PatternExpand + #::patterncipher::>cipher_bytesizes .. Create $this -data_block_bytes 8 -iv_bytes 8 -key_byte_sizes [list 8] + } + + + #We won't have private methods until the interface mechanism of patternpunk is settled. :/ + >ciphermaster .. PatternMethod _init_cipher_from_definitions {name} { + #don't declare any vars - so we get them all (?) + set definitions [$o_patterncipherlib . cipher_definitions] + set pkgname [dict get $definitions $name pkgrequire] + #! todo - add option to require exact version? + if {[catch {package require $pkgname} errMsg]} { + error "($this . ciphername (prop write)) unable to load package '$pkgname' for ciphername '$name' err: $errMsg" + } + set o_algocommand [dict get $definitions $name algocommand] + set o_cipherid [dict get $definitions $name cipherid] + set o_data_block_bytes [dict get $definitions $name data_block_bytes] + set o_iv_bytes [dict get $definitions $name iv_bytes] + set o_iv_static [dict get $definitions $name iv_static] + set o_iv_method [string map [list %ivb $o_iv_bytes %cn $name] [dict get $definitions $name iv_method]] + set o_key_byte_sizes [dict get $definitions $name key_byte_sizes] + set o_ciphermodes [dict get $definitions $name modes] + set o_mode [lindex $o_ciphermodes 0] + set o_ciphername $name + puts stdout "init_cipher_from_definitions running in [namespace current]" + } + + + >ciphermaster .. PatternProperty ciphername + >ciphermaster .. PatternPropertyWrite ciphername {name} { + var this o_patterncipherlib o_ciphername o_cipherid o_mode o_ciphertoken o_cipherbin + var o_data_block_bytes o_iv_bytes o_iv_static o_iv_method o_key_byte_sizes o_algocommand o_ciphermodes + + set definitions [$o_patterncipherlib . cipher_definitions] + + if {$name ni [dict keys $definitions]} { + puts stdout "known ciphernames: [dict keys $definitions]" + error "($this . ciphername (prop write)) cipher '$name' not known in this patterncipherlib: $o_patterncipherlib" + } + + if {[string length $o_cipherbin]} { + $this . ciphertext_header_info [string range $o_cipherbin 0 9] .. As header_info + if {[dict get $header_info status] != 1} { + error "($this . reset) Cannot reset IV while there is unfinalised ciphertext. call 'decrypt_and_reset' or 'abandon' first" + } + } + + + if {[string length $o_ciphername]} { + if {$name ne $o_ciphername} { + #changing from one cipher to another + + + if {[string length $o_ciphertoken]} { + $this . abandon + + #if {[catch {${o_algocommand}::Final $o_ciphertoken} errMsg]} { + # puts stderr "($this . ciphername (prop write)) changing ciphername $o_ciphername to $name . err calling Final with previous token $o_ciphertoken. Err: $errMsg" + #} + } + + } else { + #same name as before - warning because this is the wrong way to reset - if that's what was intended. + #puts stderr "($this . ciphername (prop write)) WARNING ciphername is already '$name'" + # constructor legitimately does this though - and in that case we need to run the reset operations below + + } + } + + #loads packages and sets vars + $this . _init_cipher_from_definitions $name + + + set o_ciphername $name + + #$this . reset + return $name + } + + #vars need to be declared as a PatternVariable or PatternProperty if we ever want them auto-declared + >ciphermaster .. PatternVariable o_algocommand + >ciphermaster .. PatternVariable o_iv_method + >ciphermaster .. PatternVariable o_ciphermodes + >ciphermaster .. PatternVariable o_iv_manually_set 0;#bool indicates was set via '. iv'. Resets each round unless o_iv_static is true. + >ciphermaster .. PatternVariable o_tailbuffer "" ;#remaining 1 to ($data_block_bytes -1) characters from when encrypt called with data not a multiple of $data_block_bytes bytes + >ciphermaster .. PatternVariable o_cipherpadding_numbytes 0 + + + + #NOTE - other properties are overlayed/mixed in during object construction in the Constructor + # e.g from >cipher_bytesizes + >ciphermaster .. PatternProperty patterncipherlib + >ciphermaster .. PatternProperty key "" ;# encryption key of size in $key_byte_sizes + >ciphermaster .. PatternProperty iv "" ;#$iv_bytes initialisation vector. Will be randomly created each round unless explicitly set. + >ciphermaster .. PatternProperty mode + >ciphermaster .. PatternProperty padschemeid 0;#1 = text based, ascii85 encoded, with paddingsize buckets + >ciphermaster .. PatternProperty padschemename ;# + >ciphermaster .. PatternProperty iv_static ;#whether or not random IV used each reset/init + + + >ciphermaster .. PatternProperty cipherid BFS ;#default - will only be used if cipherkey is not empty string + >ciphermaster .. PatternPropertyWrite cipherid {id} { + var o_cipherid o_patterncipherlib + if {$id ni [$o_patterncipherlib . cipherids]} { + error "($this . cipherid (property write)) cipherid '$id' not in list of known ciphers '[$o_patterncipherlib . cipherids]'" + } + error "not safe" + set o_cipherid $id + } + + >ciphermaster .. PatternVariable o_ciphertoken "" + >ciphermaster .. PatternPropertyRead ciphertoken "" { + var o_ciphertoken + return $o_ciphertoken + } + >ciphermaster .. PatternProperty cipherbin "" + + >ciphermaster .. PatternVariable o_chunknum 0 ;# + >ciphermaster .. PatternPropertyRead chunknum {} { + var o_chunknum + return o_chunknum + } + >ciphermaster .. PatternVariable o_chunklist [list] ;#no need for chunknum? + + >ciphermaster .. PatternProperty ciphertext ;#leave unset - underlying variable should never have a value. ciphertext is a dynamic property based on cipherbin + + + >ciphermaster .. PatternMethod padschemeinfo {{schemeid ""}} { + switch $schemeid { + "0" { + return [list scheme "text-minpad" notes "ascii85 encoded, minimum padding - at least 1 at most $o_data_block_bytes"] + } + "1" { + return [list scheme "text-buckets" notes "ascii85 encoded"] + } + "2" { + return [list scheme "binary-minpad" notes ""] + } + "3" { + return [list scheme "binary-buckets" notes ""] + } + default { + return [list scheme "unknown" notes "implemented padding schemes are [$o_patterncipherlib . padding_schemes]"] + } + } + } + + >ciphermaster .. PatternPropertyRead token {} { + var o_ciphertoken + return $o_ciphertoken + } + >ciphermaster .. PatternPropertyWrite mode {m} { + var this o_mode o_ciphermodes + if {$m ni $o_ciphermodes} { + error "($this . mode (write)) ERROR: supported modes are $o_ciphermodes" + } + set o_mode $m + } + >ciphermaster .. PatternPropertyRead ciphertext {args} { + var this o_cipherbin o_cipherpadding_numbytes o_cipherid o_patterncipherlib + if {$args eq [list -interim 1]} { + #allow bypassing header check for debug/test + set ascii85_payload [ascii85::encode -maxlen [$o_patterncipherlib . ascii85_wraplen] $o_cipherbin] + return "INTERIM.$ascii85_payload" + } + + $this . ciphertext_header_info $o_cipherbin .. As header_info + if {([dict get $header_info status] != 1)} { + if {([dict get $header_info hdr_cipherid] eq $o_cipherid ) && ([llength [dict get $header_info errors]])} { + #A finalisation header has been written - but something went wrong + error "(cipherbin) Something went wrong. Suggest calling '. abandon' and retrying. errors: [dict get $header_info errors]" + } else { + error "(cipherbin) Not yet retrievable - call '. encrypt -last 1' first." + } + } else { + set header [string range $o_cipherbin 0 7] + set ascii85_payload [ascii85::encode -maxlen [$o_patterncipherlib . ascii85_wraplen] [string range $o_cipherbin 8 end]] + return $header$ascii85_payload ;#cyphertext with header + } + } + >ciphermaster .. PatternPropertyWrite ciphertext {frame_of_encrypted_data} { + var this o_patterncipherlib o_cipherbin o_cipherpadding_numbytes o_cipherid o_ciphertoken + if {[string length $o_cipherbin]} { + error "(cipherbin property write) There already seems to be an encryption operation underway - call decrypt to retrieve it." + } + #check header + $this . ciphertext_header_info $frame_of_encrypted_data .. As header_info + if {[dict get $header_info status] == 1} { + if {[dict get $header_info hdr_cipherid] ne $o_cipherid } { + error "(cipherbin property write) cipher in ciphertext [dict get $header_info hdr_cipherid] doesn't match currently configured cipher $o_cipherid" + } + + if {![string length $o_ciphertoken]} { + $this . initcipher + } + set schemeid [dict get $header_info hdr_schemeid] + set bucketid [dict get $header_info hdr_bucketid] + set paybytes [dict get $header_info hdr_paybytes] + set paylen [dict get $header_info paylen] + set padlen [dict get $header_info padlen] + set o_cipherpadding_numbytes $padlen + if {$schemeid in {0 1}} { + #text based ascii85 + set head [string range $frame_of_encrypted_data 0 7] + set binary [::ascii85::decode [string range $frame_of_encrypted_data 8 end]] + set o_cipherbin $head$binary + } else { + #already binary + set o_cipherbin $frame_of_encrypted_data + } + + } else { + error "(ciphertext property write) ciphertext doesn't have proper header e.g 0BFS0FFF" + } + + } + >ciphermaster .. PatternPropertyRead cipherbin {args} { + var this o_cipherbin o_cipherpadding_numbytes o_cipherid + if {$args eq [list -interim 1]} { + #allow bypassing header check for debug/test + return $o_cipherbin + } + + + #check for #AAA0XXX header where # is a number from 1 to 8 and AAA is a cipher hint such as BFS or AES - this indicates --last has been called on encrypt and the ciphertext is ready to retrieve. + $this . ciphertext_header_info $o_cipherbin .. As header_info + + if {([dict get $header_info status] != 1)} { + if {([dict get $header_info hdr_cipherid] eq $o_cipherid ) && ([llength [dict get $header_info errors]])} { + #A finalisation header has been written - but something went wrong + error "(cipherbin) Something went wrong. Suggest calling '. abandon' and retrying. errors: [dict get $header_info errors]" + } else { + error "(cipherbin) Not yet retrievable - call '. encrypt -last 1' first." + } + } else { + return $o_cipherbin ;#cyphertext with header + } + } + >ciphermaster .. PatternPropertyWrite cipherbin {encrypted_data} { + var this o_patterncipherlib o_cipherbin o_cipherpadding_numbytes o_cipherid o_ciphertoken + if {[string length $o_cipherbin]} { + error "(cipherbin property write) There already seems to be an encryption operation underway - call decrypt to retrieve it." + } + + #check header + $this . ciphertext_header_info $encrypted_data .. As header_info + if {[dict get $header_info status] == 1} { + if {[dict get $header_info hdr_cipherid] ne $o_cipherid } { + error "(cipherbin property write) cipher in ciphertext [dict get $header_info hdr_cipher] doesn't match currently configured cipher $o_cipherid" + } + + if {![string length $o_ciphertoken]} { + $this . initcipher + } + set schemeid [dict get $header_info hdr_schemeid] + set bucketid [dict get $header_info hdr_bucketid] + set paybytes [dict get $header_info hdr_paybytes] + set paylen [dict get $header_info paylen] + set padlen [dict get $header_info padlen] + set o_cipherpadding_numbytes $padlen + + + set o_cipherbin $encrypted_data + } else { + error "(cipherbin property write) ciphertext doesn't have proper header e.g 0BFS0FFF" + } + } + >ciphermaster .. PatternPropertyUnset cipherbin {keypattern} { + var o_cipherbin + if {[string length $o_cipherbin]} { + error "($this . cipherbin (unset)) ERROR: cannot unset cipherbin - currently contains [string length $o_cipherbin] bytes." + } + } + >ciphermaster .. PatternPropertyWrite key {key_or_emptystring} { + var this o_data_block_bytes o_key o_ciphername o_key_byte_sizes + set datalen [string length $key_or_emptystring] + if {$datalen} { + if {($datalen ni $o_key_byte_sizes)} { + error "($this . key (write)) ERROR: bad key. $o_ciphername valid keylengths: '$o_key_byte_sizes'. Received $datalen bytes." + } + set newkey $key_or_emptystring + set oldkey $o_key + if {[string length $oldkey]} { + if {$newkey ne $oldkey} { + puts stderr "($this . key (write)) WARNING: changing $o_ciphername encipherment key '$oldkey' -> $newkey" + } + } + + } + set o_key $key_or_emptystring + } + + >ciphermaster .. PatternPropertyWrite iv {new_iv} { + var this o_ciphertoken o_iv o_iv_bytes o_iv_manually_set o_cipherbin o_algocommand + var o_iv_method o_patterncipherlib + + #puts "----> o_iv_method: $o_iv_method" + if {[string length $o_cipherbin]} { + error "($this . iv (write)) Cannot set IV while there is active cipher ciphertext. call 'decrypt_and_reset' or 'abandon' first" + } + + set library_passed_iv [{*}[concat $o_patterncipherlib . $o_iv_method -userdata $new_iv]] + + if {[string length $library_passed_iv] != $o_iv_bytes} { + error "($this . iv (write))IV returned by '[concat $o_patterncipherlib . $o_iv_method -userdata $new_iv]' was not $o_iv_bytes bytes long. Cipher configuration/library error?" + } + set o_iv $library_passed_iv + set o_iv_manually_set 1 + if {[string length $o_ciphertoken]} { + ${o_algocommand}::Reset $o_ciphertoken $o_iv + } + } + + + >ciphermaster .. PatternMethod reset {} { + var this o_ciphertoken o_iv o_iv_static o_iv_manually_set o_iv_bytes o_iv_method o_cipherbin + var o_tailbuffer o_cipherpadding_numbytes o_patterncipherlib o_algocommand + if {[string length $o_cipherbin]} { + $this . ciphertext_header_info [string range $o_cipherbin 0 9] .. As header_info + if {[dict get $header_info status] != 1} { + error "($this . reset) Cannot reset IV while there is unfinalised ciphertext. call 'decrypt_and_reset' or 'abandon' first" + } + } + if {$o_iv_static} { + #leave state of o_iv and o_iv_manually set as is + } else { + set o_iv_manually_set 0 + #set o_iv [$o_patterncipherlib . get_random_bytes $o_iv_bytes] + set o_iv [{*}[concat $o_patterncipherlib . $o_iv_method]] + } + set o_cipherbin "" + set o_tailbuffer "" + set o_cipherpadding_numbytes 0 + if {[string length $o_ciphertoken]} { + ${o_algocommand}::Reset $o_ciphertoken $o_iv + } + } + >ciphermaster .. PatternMethod initcipher {} { + var this o_key o_key_byte_sizes o_iv o_iv_bytes o_iv_static o_iv_method o_iv_manually_set o_iv_previous + var o_ciphertoken o_mode o_cipherbin o_patterncipherlib o_algocommand + if {[string length $o_cipherbin]} { + error "($this . init) Cannot init while there is active cipher ciphertext. call 'decrypt_and_reset' or 'abandon' first or 'reset' if ciphertext has been finalised" + } + + + if {!$o_iv_manually_set} { + #set o_iv [$o_patterncipherlib . get_random_bytes $o_iv_bytes] + set o_iv [{*}[concat $o_patterncipherlib . $o_iv_method]] + + } else { + if {$o_iv_static} { + #leave state of o_iv because it was manually configured and static + } else { + if {$o_iv eq $o_iv_previous} { + #change because not meant to be static + #set o_iv [$o_patterncipherlib . get_random_bytes $o_iv_bytes] + set o_iv [{*}[concat $o_patterncipherlib . $o_iv_method]] + } + } + } + set o_iv_previous $o_iv + + if {[string length $o_key] ni $o_key_byte_sizes} { + error "(initcipher) '$this . key' current keylength:[string length $o_key] is wrong. Allowed lengths in bytes: '$o_key_byte_sizes'" + } + + set o_ciphertoken [${o_algocommand}::Init $o_mode $o_key $o_iv] + } + + >ciphermaster .. PatternMethod encryptlast {{newdata ""}} { + tailcall encrypt $_ID_ $newdata -last 1 + } + >ciphermaster .. PatternMethod encrypt {newdata args} { + var this o_ciphertoken o_cipherbin o_data_block_bytes o_key o_iv o_iv_bytes o_cipherpadding_numbytes o_tailbuffer o_patterncipherlib o_padschemeid o_cipherid o_algocommand + + #---------------------------------------------------------------------------- + set known_opts [list -last -show -key -iv] + dict set default -last 0 ;#when -last 1 do padding + dict set default -show 0 ;#echo $o_cipherbin to stdout + dict set default -reopen 0 ;#todo add -reopen by adding another bucket? + if {([llength $args] % 2) != 0} { + error "($this . encrypt) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "(($this . encrypt) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set option_last [dict get $opts -last] + set option_show [dict get $opts -show] + set option_reopen [dict get $opts -reopen] + #---------------------------------------------------------------------------- + + if {![string length $o_ciphertoken]} { + $this . initcipher + } + if {$o_cipherpadding_numbytes > 0} { + #once there is padding in the ciphertext data - we know this encrypt round is at an end. + error "($this . encrypt) Ciphertext is already finalised. Retrieve with '. ciphertext' and verify with '. decrypt_and_reset' before retrying." + } + + set newdata "$o_tailbuffer$newdata" ;#data we're adding in this method call + set o_tailbuffer "" + + if {$o_data_block_bytes > 0} { + set last_data_block_size [expr {[string length $newdata] % $o_data_block_bytes}] ;#if 0, newdata was a multiple of $o_data_block_bytes bytes + set blocksize $o_data_block_bytes + } else { + #non 'block-based' data - we'll never need padding + set blocksize [string length $newdata] + set last_data_block_size [string length $newdata] + } + set padding "" + + + if {![string length $o_cipherbin]} { + #first chunk to store in ciphertext. ciphertext requires 8 byte iv prepended + set o_cipherbin $o_iv ;# IV required for decryption + } + #o_cipherbin always has iv data at start now. + set iv_plus_content_size [expr {[string length $o_cipherbin ] + [string length $newdata]}] ;#iv + data is the payload the encrypter operates on + + if {$option_last} { + #treat as full bucket + set end_of_bucket 1 + } else { + #detect if we've filled a bucket + set end_of_bucket 0 + } + + + if {$end_of_bucket} { + #if we're already at a multiple of data_block_bytes bytes, still add padding so we can use o_cipherpadding_numbytes = 0 as a flag + + #New header of form #BFSHXLl where # is padding scheme X, BFSH is cipher, X is bucket code and Ll is the payload size (not including header) + #calculate size of the bucket needed for ascii85 encoded version of the payload + 8byte header + $blocksize bytes of minpadding + + #!todo - lookup text/vs binary from schemeinfo + if {$o_padschemeid in {0 1}} { + #text schemes + set hex_pay_len [format %04x $iv_plus_content_size] + set possible_newlines [expr {entier($iv_plus_content_size / [$o_patterncipherlib . ascii85_wraplen])}] + #review - guess vs redundant ascii85 encoding work? + set ascii85_content_size_guess [expr {entier(ceil(($iv_plus_content_size/4.0)*5)) + $possible_newlines}] ;#why guess? + set ascii85_payload [ascii85::encode -maxlen [$o_patterncipherlib . ascii85_wraplen] $o_cipherbin$newdata] + + if {$ascii85_content_size_guess != [string length $ascii85_payload]} { + puts stdout "(encrypt) WARNING: ascii85 guess: '$ascii85_content_size_guess' vs ascii85 actual: '[string length $ascii85_payload]'" + } + + set bucket_info [$o_patterncipherlib . get_bucket_info $ascii85_content_size_guess] + set bucket_hex1 [dict get $bucket_info hex1] ; #1 byte hex + set bucket_size [dict get $bucket_info size] + + if {$o_padschemeid eq "0"} { + #text-minpad + set data_needed_bytes [expr {$blocksize - $last_data_block_size}] ;# assertion: needed_bytes is always 1 to $o_data_block_bytes + set needed_bytes $data_needed_bytes + set padding [string repeat * $needed_bytes] ;#primitive padding - #!todo review. + + set header "0${o_cipherid}0[string range ${hex_pay_len} 1 end]" + } elseif {$o_padschemeid eq "1"} { + #text-buckets + set data_needed_bytes [expr {$blocksize - $last_data_block_size}] + puts stdout ">> data_needed_bytes: $data_needed_bytes" + set needed_bytes [expr {$bucket_size - 8 - $iv_plus_content_size}] + if {(8 + $iv_plus_content_size + $needed_bytes) != $bucket_size} { + error "(encrypt) ERROR: sanity_check 8 + iv&content ($iv_plus_content_size) + padding ($needed_bytes) != bucket_size ($bucket_size) - programming bug!" + } + + puts stdout ">> needed_bytes: $needed_bytes" + puts stdout ">>bucket_size: $bucket_size iv_plus_content_size: $iv_plus_content_size" + set padding [string repeat * $needed_bytes] + set header "1${o_cipherid}${bucket_hex1}[string range ${hex_pay_len} 1 end]" + } + + } elseif {$o_padschemeid in {2 3}} { + set hex_pay_len [format %04x $iv_plus_content_size] + + set bucket_info [$o_patterncipherlib . get_bucket_info $iv_plus_content_size] + set bucket_hex1 [dict get $bucket_info hex1] + set bucket_size [dict get $bucket_info size] + + set msb [string range $hex_pay_len 0 1] + set lsb [string range $hex_pay_len 2 3] + set bin_pay_len [binary format c2 [list "0x$msb" "0x$lsb"] + if {$o_padschemeid eq "2"} { + #binary-minpad + set data_needed_bytes [expr {$blocksize - $last_data_block_size}] ;# assertion: needed_bytes is always 1-$o_data_block_bytes + set needed_bytes $data_needed_bytes + set padding [$o_patterncipherlib . get_random_bytes $needed_bytes] + + set header "2${o_cipherid}${bucket_hex1}$bin_pay_len" + } elseif {$o_padschemeid eq "3"} { + #binary-buckets + set data_needed_bytes [expr {$blocksize - $last_data_block_size}] ;# assertion: needed_bytes is always 1-$o_data_block_bytes + set needed_bytes [expr {$bucket_size - 8 - $iv_plus_content_size}] + if {(8 + $iv_plus_content_size + $needed_bytes) != $bucket_size} { + error "(encrypt) ERROR: sanity_check 8 + iv&content ($iv_plus_content_size) + padding ($needed_bytes) != bucket_size ($bucket_size) - programming bug!" + } + set padding [$o_patterncipherlib . get_random_bytes $needed_bytes] + set header "3${o_cipherid}${bucket_hex1}$bin_pay_len" + } + } + + set o_cipherpadding_numbytes [string length $padding] ;#assertion: always non zero here + + set padded_data "$newdata$padding" + append o_cipherbin [${o_algocommand}::Encrypt $o_ciphertoken $padded_data] + + set o_cipherbin ${header}$o_cipherbin ;#header will make the '. ciphertext' property readable + + puts stdout "ciphertext final: >>> $o_cipherbin <<<" + #puts stderr ">>$padded_data<< [string length $padded_data] bytes" + set payload_bytes [expr [string length $o_cipherbin] - 8 - [string length $padding] - $o_iv_bytes] ;#account for IV and padding bytes to give caller an indication of + if {($payload_bytes + $o_iv_bytes) != $iv_plus_content_size} { + puts stderr "(encrypt) WARNING payloadbytes $payload_bytes != iv_plus_content_size $iv_plus_content_size" + } + + return [list payload_bytes $payload_bytes padding_bytes [string length $padding] header $header buffer_bytes [string length $o_tailbuffer] final 1] + } else { + if {$blocksize > 0} { + if {([string length $newdata] % $blocksize) != 0} { + #error "($this . encrypt) data chunk must be a multiple of $data_block_bytes bytes - call decrypt after one or more calls to encrypt, and/or call '. encrypt data_or_empty_string -last 1" + if {$last_data_block_size != 0} { + set o_tailbuffer [string range $newdata end-[expr {$last_data_block_size -1}] end] + set newdata [string range $newdata 0 end-$last_data_block_size] + } + + if {[string length $newdata]} { + puts stdout "1encrypt !! about to call ${o_algocommand}::Encrypt $o_ciphertoken $newdata" + append o_cipherbin [${o_algocommand}::Encrypt $o_ciphertoken $newdata] + } + } else { + puts stdout "2encrypt !! about to call ${o_algocommand}::Encrypt $o_ciphertoken $newdata" + append o_cipherbin [${o_algocommand}::Encrypt $o_ciphertoken $newdata] + } + } else { + puts stdout "3encrypt !! about to call ${o_algocommand}::Encrypt $o_ciphertoken $newdata" + append o_cipherbin [${o_algocommand}::Encrypt $o_ciphertoken $newdata] + } + set payload_bytes [expr [string length $o_cipherbin] - $o_iv_bytes] ;#account for IV to give caller an indication of payload bytes + + puts stdout "ciphertext: >>> $o_cipherbin padding:$padding should still be 0<<<" + return [list payload_bytes $payload_bytes padding_bytes [string length $padding] buffer_bytes [string length $o_tailbuffer] final 0] + } + + } + + + #abandon any currently-building ciphertext - drop the token + >ciphermaster .. PatternMethod abandon {} { + var this o_ciphertoken o_cipherbin o_cipherpadding_numbytes o_algocommand o_tailbuffer o_iv o_iv_manually_set + puts stdout "($this . abandon) Abandoning any active ciphertext. Encipherment key unchanged. Key-schedule will be regenerated (previous token Finalised)" + + catch {${o_algocommand}::Final $o_ciphertoken} + + set o_ciphertoken "" + set o_cipherbin "" + set o_tailbuffer "" + set o_iv "" + set o_iv_manually_set 0 + set o_cipherpadding_numbytes 0 + } + + #for some schemes - the info returned by ciphertext_header_info is only accurate if the full ciphertext is supplied - not just the header + # hdr_ fields can be trusted if an appropriately truncated ciphertext is supplied, but fields such as padlen may require the complete bucket. + >ciphermaster .. PatternMethod ciphertext_header_info {ciphertext} { + set schemeid [string range $ciphertext 0 0] ;#e.g 0, 1, 2 + set cipherid [string range $ciphertext 1 3] ;#e.g BFS, AES + set bucketid [string range $ciphertext 4 4] ;#hexchar 0-F + set paybytes [string range $ciphertext 5 7] ;#3bytes hex or binary payload length + set endiv [expr {(8 + $o_iv_bytes) -1}] + set cipheriv [string range $ciphertext 8 $endiv] ;# Initialisation vector + set errors [list] + #8 byte header for all schemeids for now + + if {(![string is integer -strict $schemeid]) || ($cipherid ni [$o_patterncipherlib . cipherids]) || (![string is xdigit -strict $bucketid]) || ([string length $paybytes] != 3)} { + lappend errors [expr {(![string is integer -strict $schemeid]) ? "bad schemeid" : ""}] + lappend errors [expr {($cipherid ni [$o_patterncipherlib . cipherids]) ? "cipherid '$cipherid' unknown" : ""}] + lappend errors [expr {(![string is xdigit -strict $bucketid]) ? "non-hex bucketid" : ""}] + lappend errors [expr {([string length $paybytes] != 3) ? "paybytes len != 3" : ""}] + set errors [lsearch -all -inline -not -exact $errors ""] ;#strip empty strings from error list + return [list status 0 hdr_schemeid $schemeid hdr_cipherid $cipherid hdr_bucketid $bucketid hdr_paybytes $paybytes iv $cipheriv errors $errors] + } + + #calculate payload length from paybytes + #for now - hard code the schemes here + set paylen_is_hex 0 + set paylen_is_binary 0 + if {$schemeid in {0 1}} { + set paylen_is_hex 1 + } elseif {$schemeid in {2 3}} { + set paylen_is_binary 1 + } else { + error "schemeid $schemeid unimplemented" + } + + if {$paylen_is_hex} { + set paylen [scan $paybytes %x] + } elseif {$paylen_is_binary} { + #test create a paylen with something like: set bin [binary format c3 {0x00 0x01 0x0A} + #H bigendian h smallendian + binary scan $paylen H3 v ;# turn to hex such as 00010a + set paylen [scan $v %x] ;# back to decimal + } + + if {$bucketid != 0} { + set bucketsize [dict get [$o_patterncipherlib . bucketsize_by_hex1] $bucketid] + set padlen [expr {$bucketsize - 8 - $paylen}] + } else { + set bucketsize 0 + set padlen [expr {[string length $ciphertext] - 8 - $paylen}] + } + + return [list status 1 hdr_schemeid $schemeid hdr_cipherid $cipherid hdr_bucketid $bucketid hdr_paybytes $paybytes iv $cipheriv bucketsize $bucketsize paylen $paylen padlen $padlen errors [list]] ;#always return errors member even if empty + + } + + #todo - detect if ciphertext hasn't been retrieved + >ciphermaster .. PatternMethod decrypt {} { + error "(decrypt) Call decrypt_and_reset to verify after retrieving encrypted data with '. ciphertext'" + } + + >ciphermaster .. PatternMethod decrypt_and_reset {} { + var this o_ciphertoken o_cipherbin o_tailbuffer o_cipherpadding_numbytes + var o_iv o_iv_bytes o_iv_static o_iv_method o_patterncipherlib o_cipherid o_algocommand + + if {![string length $o_cipherbin]} { + error "No data to decrypt - call encrypt first. After one or more calls to encrypt ending with '. encrypt -last', retrieve '. ciphertext' and call decrypt_and_reset to retrieve/verify plaintext chunk." + } + $this . ciphertext_header_info $o_cipherbin .. As header_info + if {([dict get $header_info status] != 1)} { + if {([dict get $header_info hdr_cipherid] eq $o_cipherid ) && ([llength [dict get $header_info errors]])} { + #A finalisation header has been written - but something went wrong + error "(decrypt_and_reset) Something went wrong. Suggest calling '. abandon' and retrying. errors: [dict get $header_info errors]" + } else { + error "(decrypt_and_reset) Not yet retrievable - call '. encrypt -last 1' first." + } + } + + set bucketid [dict get $header_info hdr_bucketid] + set bucketsize [dict get $header_info bucketsize] + + set padlen [dict get $header_info padlen] + set paylen [dict get $header_info paylen] + #sanity checks + if {$o_cipherpadding_numbytes != $padlen} { + puts stderr "WARNING!! stored o_cipherpadding_numbytes '$o_cipherpadding_numbytes' != '. ciphertext_header_info' padlen '$padlen'" + } + if {([string length $o_cipherbin] -8 -$padlen) != $paylen} { + puts stderr "WARNING!! length of stored o_cipherbin - 8 '[expr {[string length $o_cipherbin] -8}]' != '.ciphertext_header_info' paylen '$paylen'" + } + + puts stdout "------------------------------------------------------" + puts stdout "About to decrypt: IV+encdata '[string range $o_cipherbin 8 80]...' with token $o_ciphertoken" + puts stdout "------------------------------------------------------" + set plaintext [${o_algocommand}::Decrypt $o_ciphertoken [string range $o_cipherbin 8 end]] ;#don't pass our #BFSXXXX- header to the ${o_algocommand} library + puts stdout "full decrypted plaintext [string length $plaintext] bytes including iv and padding (padlen:$padlen paylen $paylen bucketsize: $bucketsize) :" + puts stdout "------------------------------------------------------" + puts stdout "$plaintext" + puts stdout "------------------------------------------------------" + + #set padlength $o_cipherpadding_numbytes + #reset + + #${o_algocommand}::Final $o_ciphertoken + #set o_ciphertoken "" + #set o_iv [$o_patterncipherlib . get_random_bytes $o_iv_bytes] + if {!$o_iv_static} { + set o_iv [{*}[concat $o_patterncipherlib . $o_iv_method]] + } + + ${o_algocommand}::Reset $o_ciphertoken $o_iv + + set o_cipherbin "" + set o_tailbuffer "" + set o_cipherpadding_numbytes 0 ;#important to reset this + #strip iv and padding to recover original data + return [string range $plaintext $o_iv_bytes end-$padlen] + } + + >ciphermaster .. Destructor {} { + var o_ciphertoken o_algocommand + ${o_algocommand}::Final $o_ciphertoken + } + +} + + +namespace eval ::patterncipher { + + set created_cipherpatterns [list] + foreach ciphername [::patterncipher::libs::>lib_standard . ciphernames] { + >pattern .. Create >cipher1 + >cipher1 .. Variable o_ciphername $ciphername ;#for help method on the prototype object + >cipher1 .. PatternVariable o_ciphername $ciphername + >cipher1 .. Clone >$ciphername ;#clone brings along its default values + >cipher1 .. Destroy + + >ciphermaster .. Clone >$ciphername + lappend created_cipherpatterns [namespace current]::>$ciphername + } + puts stdout "Created patterncipher cipherpattern objects: $created_cipherpatterns" + +} + + + + + + + + + diff --git a/src/bootsupport/modules/patterncmd-1.2.8.tm b/src/bootsupport/modules/patterncmd-1.2.8.tm new file mode 100644 index 00000000..76ade79f --- /dev/null +++ b/src/bootsupport/modules/patterncmd-1.2.8.tm @@ -0,0 +1,639 @@ +package provide patterncmd [namespace eval patterncmd { + variable version + set version 1.2.8 +}] + + +namespace eval pattern { + variable idCounter 1 ;#used by pattern::uniqueKey + + namespace eval cmd { + namespace eval util { + package require overtype + variable colwidths_lib [dict create] + variable colwidths_lib_default 15 + + dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] + dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] + dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] + dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] + + proc colhead {type args} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname [string totitle $colname] {*}$args]" + } + return $line + } + proc colbreak {type} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" + } + return $line + } + proc col {type col val args} { + # args -head bool -tail bool ? + #---------------------------------------------------------------------------- + set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] + dict set default -backchar "" + dict set default -headchar "" + dict set default -tailchar "" + dict set default -headoverridechar "" + dict set default -tailoverridechar "" + dict set default -justify "left" + if {([llength $args] % 2) != 0} { + error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set backchar [dict get $opts -backchar] + set headchar [dict get $opts -headchar] + set tailchar [dict get $opts -tailchar] + set headoverridechar [dict get $opts -headoverridechar] + set tailoverridechar [dict get $opts -tailoverridechar] + set justify [dict get $opts -justify] + #---------------------------------------------------------------------------- + + + + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + #calculate headwidths + set headwidth 0 + set tailwidth 0 + foreach {key def} $colwidths { + set thisheadlen [string length [dict get $def head]] + if {$thisheadlen > $headwidth} { + set headwidth $thisheadlen + } + set thistaillen [string length [dict get $def tail]] + if {$thistaillen > $tailwidth} { + set tailwidth $thistaillen + } + } + + + set spec [dict get $colwidths $col] + if {[string length $backchar]} { + set ch $backchar + } else { + set ch [dict get $spec ch] + } + set num [dict get $spec num] + set headchar [dict get $spec head] + set tailchar [dict get $spec tail] + + if {[string length $headchar]} { + set headchar $headchar + } + if {[string length $tailchar]} { + set tailchar $tailchar + } + #overrides only apply if the head/tail has a length + if {[string length $headchar]} { + if {[string length $headoverridechar]} { + set headchar $headoverridechar + } + } + if {[string length $tailchar]} { + if {[string length $tailoverridechar]} { + set tailchar $tailoverridechar + } + } + set head [string repeat $headchar $headwidth] + set tail [string repeat $tailchar $tailwidth] + + set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] + if {$justify eq "left"} { + set left_done [overtype::left $base "$head$val"] + return [overtype::right $left_done "$tail"] + } elseif {$justify in {centre center}} { + set mid_done [overtype::centre $base $val] + set left_mid_done [overtype::left $mid_done $head] + return [overtype::right $left_mid_done $tail] + } else { + set right_done [overtype::right $base "$val$tail"] + return [overtype::left $right_done $head] + } + + } + + } + } + +} + +#package require pattern + +proc ::pattern::libs {} { + set libs [list \ + pattern {-type core -note "alternative:pattern2"}\ + pattern2 {-type core -note "alternative:pattern"}\ + patterncmd {-type core}\ + metaface {-type core}\ + patternpredator2 {-type core}\ + patterndispatcher {-type core}\ + patternlib {-type core}\ + patterncipher {-type optional -note optional}\ + ] + + + + package require overtype + set result "" + + append result "[cmd::util::colbreak lib]\n" + append result "[cmd::util::colhead lib -justify centre]\n" + append result "[cmd::util::colbreak lib]\n" + foreach libname [dict keys $libs] { + set libinfo [dict get $libs $libname] + + append result [cmd::util::col lib library $libname] + if {[catch [list package present $libname] ver]} { + append result [cmd::util::col lib version "N/A"] + } else { + append result [cmd::util::col lib version $ver] + } + append result [cmd::util::col lib type [dict get $libinfo -type]] + + if {[dict exists $libinfo -note]} { + set note [dict get $libinfo -note] + } else { + set note "" + } + append result [cmd::util::col lib note $note] + append result "\n" + } + append result "[cmd::util::colbreak lib]\n" + return $result +} + +proc ::pattern::record {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply { + {index rec args} + { + if {[llength $args] == 0} { + return [lindex $rec $index] + } + if {[llength $args] == 1} { + return [lreplace $rec $index $index [lindex $args 0]] + } + error "Invalid number of arguments." + } + + }] + + set map {} + foreach field $fields { + dict set map $field [linsert $accessor end [incr index]] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} +proc ::pattern::record2 {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply] + + set template { + {rec args} + { + if {[llength $args] == 0} { + return [lindex $rec %idx%] + } + if {[llength $args] == 1} { + return [lreplace $rec %idx% %idx% [lindex $args 0]] + } + error "Invalid number of arguments." + } + } + + set map {} + foreach field $fields { + set body [string map [list %idx% [incr index]] $template] + dict set map $field [list ::apply $body] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} + +proc ::argstest {args} { + package require cmdline + +} + +proc ::pattern::objects {} { + set result [::list] + + foreach ns [namespace children ::pp] { + #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] + set ch [namespace tail $ns] + if {[string range $ch 0 2] eq "Obj"} { + set OID [string range $ch 3 end] ;#OID need not be digits (!?) + lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] + } + } + + return $result +} + + + +proc ::pattern::name {num} { + #!todo - fix + #set ::p::${num}::(self) + + lassign [interp alias {} ::p::$num] _predator info + if {![string length $_predator$info]} { + error "No object found for num:$num (no interp alias for ::p::$num)" + } + set invocants [dict get $info i] + set invocants_with_role_this [dict get $invocants this] + set invocant_this [lindex $invocants_with_role_this 0] + + + #lassign $invocant_this id info + #set map [dict get $info map] + #set fields [lindex $map 0] + lassign $invocant_this _id _ns _defaultmethod name _etc + return $name +} + + +proc ::pattern::with {cmd script} { + foreach c [info commands ::p::-1::*] { + interp alias {} [namespace tail $c] {} $c $cmd + } + interp alias {} . {} $cmd . + interp alias {} .. {} $cmd .. + return [uplevel 1 $script] +} + + + + + +#system diagnostics etc + +proc ::pattern::varspace_list {IID} { + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables + + set varspaces [list] + dict for {vname vdef} $o_variables { + set vs [dict get $vdef varspace] + if {$vs ni $varspaces} { + lappend varspaces $vs + } + } + if {$o_varspace ni $varspaces} { + lappend varspaces $o_varspace + } + return $varspaces +} + +proc ::pattern::check_interfaces {} { + foreach ns [namespace children ::p] { + set IID [namespace tail $ns] + if {[string is digit $IID]} { + foreach ref [array names ${ns}::_iface::o_usedby] { + set OID [string range $ref 1 end] + if {![namespace exists ::p::${OID}::_iface]} { + puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" + } else { + puts -nonewline stdout . + } + + + #if {![info exists ::p::${OID}::(self)]} { + # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" + #} + } + } + } + puts -nonewline stdout "\r\n" +} + + +#from: http://wiki.tcl.tk/8766 (Introspection on aliases) +#usedby: metaface-1.1.6+ +#required because aliases can be renamed. +#A renamed alias will still return it's target with 'interp alias {} oldname' +# - so given newname - we require which_alias to return the same info. + proc ::pattern::which_alias {cmd} { + uplevel 1 [list ::trace add execution $cmd enterstep ::error] + catch {uplevel 1 $cmd} res + uplevel 1 [list ::trace remove execution $cmd enterstep ::error] + #puts stdout "which_alias $cmd returning '$res'" + return $res + } +# [info args] like proc following an alias recursivly until it reaches +# the proc it originates from or cannot determine it. +# accounts for default parameters set by interp alias +# + + +proc ::pattern::aliasargs {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info args $cmd] + # strip off the interp set default args + return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } +} + +proc ::pattern::aliasbody {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info body $cmd] + # strip off the interp set default args + return $result + #return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } + } + + + + + +proc ::pattern::uniqueKey2 {} { + #!todo - something else?? + return [clock seconds]-[incr ::pattern::idCounter] +} + +#used by patternlib package +proc ::pattern::uniqueKey {} { + return [incr ::pattern::idCounter] + #uuid with tcllibc is about 30us compared with 2us + # for large datasets, e.g about 100K inserts this would be pretty noticable! + #!todo - uuid pool with background thread to repopulate when idle? + #return [uuid::uuid generate] +} + + + +#------------------------------------------------------------------------------------------------------------------------- + +proc ::pattern::test1 {} { + set msg "OK" + + puts stderr "next line should say:'--- saystuff:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternMethod saystuff args { + puts stderr "--- saystuff: $args" + } + ::>thing .. Create ::>jjj + + ::>jjj . saystuff $msg + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test2 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternProperty stuff $msg + + ::>thing .. Create ::>jjj + + puts stderr "--- property 'stuff' value:[::>jjj . stuff]" + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test3 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. Property stuff $msg + + puts stderr "--- property 'stuff' value:[::>thing . stuff]" + ::>thing .. Destroy +} + +#--------------------------------- +#unknown/obsolete + + + + + + + +#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} + +if {0} { + proc ::p::internals::new_interface {{usedbylist {}}} { + set OID [incr ::p::ID] + ::p::internals::new_object ::p::ifaces::>$OID "" $OID + puts "obsolete >> new_interface created object $OID" + foreach usedby $usedbylist { + set ::p::${OID}::_iface::o_usedby(i$usedby) 1 + } + set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) + #NOTE - o_varspace is only the default varspace for when new methods/properties are added. + # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. + + set ::p::${OID}::_iface::o_constructor [list] + set ::p::${OID}::_iface::o_variables [list] + set ::p::${OID}::_iface::o_properties [dict create] + set ::p::${OID}::_iface::o_methods [dict create] + array set ::p::${OID}::_iface::o_definition [list] + set ::p::${OID}::_iface::o_open 1 ;#open for extending + return $OID + } + + + #temporary way to get OID - assumes single 'this' invocant + #!todo - make generic. + proc ::pattern::get_oid {_ID_} { + #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" + return [lindex [dict get $_ID_ i this] 0 0] + + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + #set role_members [dict get $invocants this] + ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. + #set this_invocant [lindex [dict get $_ID_ i this] 0] ; + #lassign $this_invocant OID this_info + # + #return $OID + } + + #compile the uncompiled level1 interface + #assert: no more than one uncompiled interface present at level1 + proc ::p::meta::PatternCompile {self} { + error "PatternCompile ????" + + upvar #0 $self SELFMAP + set ID [lindex $SELFMAP 0 0] + + set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces + + set iid -1 + foreach i $patterns { + if {[set ::p::${i}::_iface::o_open]} { + set iid $i ;#found it + break + } + } + + if {$iid > -1} { + #!todo + + ::p::compile_interface $iid + set ::p::${iid}::_iface::o_open 0 + } else { + #no uncompiled interface present at level 1. Do nothing. + return + } + } + + + proc ::p::meta::Def {self} { + error ::p::meta::Def + + upvar #0 $self SELFMAP + set self_ID [lindex $SELFMAP 0 0] + set IFID [lindex $SELFMAP 1 0 end] + + set maxc1 0 + set maxc2 0 + + set arrName ::p::${IFID}:: + + upvar #0 $arrName state + + array set methods {} + + foreach nm [array names state] { + if {[regexp {^m-1,name,(.+)} $nm _match mname]} { + set methods($mname) [set state($nm)] + + if {[string length $mname] > $maxc1} { + set maxc1 [string length $mname] + } + if {[string length [set state($nm)]] > $maxc2} { + set maxc2 [string length [set state($nm)]] + } + } + } + set bg1 [string repeat " " [expr {$maxc1 + 2}]] + set bg2 [string repeat " " [expr {$maxc2 + 2}]] + + + set r {} + foreach nm [lsort -dictionary [array names methods]] { + set arglist $state(m-1,args,$nm) + append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" + } + return $r + } + + +} \ No newline at end of file diff --git a/src/bootsupport/modules/patternlib-1.2.8.tm b/src/bootsupport/modules/patternlib-1.2.8.tm new file mode 100644 index 00000000..67a7cba9 --- /dev/null +++ b/src/bootsupport/modules/patternlib-1.2.8.tm @@ -0,0 +1,2588 @@ +#JMN 2004 +#public domain + + +package provide patternlib [namespace eval patternlib { + variable version + set version 1.2.8 +}] + + + +#Change History +#------------------------------------------------------------------------------- +# 2022-05 +# added . search and . itemKeys methods to >collection to enable lookups by value +# 2021-09 +# Add >keyvalprotector - an object to overload various collection methods such as 'remove' to stop deletion of specific items. +# +# 2006-05 +# deprecate 'del' in favour of 'remove' - 'del' still there but delegated to 'remove'. todo - emit deprecation warnings. +# +# 2005-04 +# remove 'name' method - incorporate indexed retrieval into 'names' method +# !todo? - adjust key/keys methods for consistency? +# +# 2004-10 +# initial key aliases support +# fix negative index support on some methods e.g remove +# 2004-08 +# separated >collection predicate methods out onto separate 'mixin' object >predicatedCollection +# added $posn $result variables to predicate methods, changed varnames from $k $v to $key $value +# +# 2004-06-05 +# added 'sort' method to sort on values. +# fixed 'keySort' method to accept multiple sort options +# added predicate methods 'all' 'allKeys' 'collectAll' +# 2004-06-01 +# '>collection . names' method now accepts optional 'glob' parameter to filter result +# 2004-05-19 +#fix '>collection . clear' method so consecutive calls don't raise an error +#------------------------------------------------------------------------------- + +namespace eval ::patternlib::util { + proc package_require_min {pkg minver} { + if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} { + package require $pkg + } else { + error "Package pattern requires package $pkg of at least version $minver. Available: $available" + } + } + + #bloom filter experiment https://wiki.tcl-lang.org/page/A+Simple+Bloom+Filter + # k-hashes + # m-bits + # n-elements + # optimal value of k: (m/n)ln(2) + #proc bloom_optimalNumHashes {capacity_n bitsize_m} { + # expr { round((double($bitsize_m) / $capacity_n) * log(2))} + #} + #proc bloom_optimalNumBits {capacity fpp} { + # expr {entier(-$capacity * log($fpp) / (log(2) * log(2)))} + #} + +} +::patternlib::util::package_require_min pattern 1.2.4 +#package require pattern +::pattern::init ;# initialises (if not already) + + +namespace eval ::patternlib {namespace export {[a-z]*} + namespace export {[>]*} + + variable keyCounter 0 ;#form part of unique keys for collections when items added without any key specified + proc uniqueKey {} { + return [incr ::patternlib::keyCounter] + } + +#!todo - multidimensional collection +# - o_list as nested list +# - o_array with compound keys(?) how will we unambiguously delimit dimensions in a concatenated key? +# - perhaps a key is always a list length n where n is the number of dimensions? +# - therefore we'll need an extra level of nesting for the current base case n=1 +# +# - how about a nested dict for each key-structure (o_list & o_array) ? + +#COLLECTION +# +#!todo? - consider putting the actual array & list vars in the objects namespace, and using the instancevars to hold their names +# - consider array-style access using traced var named same as collection. +# would this defeat the purpose ? if it was faster, would users always use array syntax in preference.. in which case they may as well just use arrays..? +#!todo - add boolean property to force unique values as well as keys + + +#::pattern::create >collection + + + + +::>pattern .. Create >collection +set COL >collection +#process_pattern_aliases [namespace origin >collection] +#process_pattern_aliases ::patternlib::>collection +$COL .. Property version 1.0 +$COL .. PatternDefaultMethod item + +set PV [$COL .. PatternVariable .] + +$PV o_data +#$PV o_array +#$PV o_list +$PV o_alias +$PV this + +#for invert method +$PV o_dupes 0 + + +$COL .. PatternProperty bgEnum + + +#PV o_ns + +$PV m_i_filteredCollection + +#set ID [lindex [set >collection] 0 0] ;#context ID +#set IID [lindex [set >collection] 1 0] ;#level 1 base-interface ID + +$COL .. Constructor {args} { + var o_data m_i_filteredCollection o_count o_bgEnum + + var this + set this @this@ + + set m_i_filteredCollection 0 + if {![llength $args]} { + set o_data [dict create] + #array set o_array [list] + #set o_list [list] + set o_count 0 + } elseif {[llength $args] == 1} { + set o_data [dict create] + set pairs [lindex $args 0] + if {[llength $pairs] % 2} { + error "patternllib::>collection - if an argument given to constructor, it must have an even number of elements. Bad args: $args" + } + set keys_seen [list] + foreach key [dict keys $pairs] { + if {[string is integer -strict $key] } { + error ">collection key must be non-integer. Bad key: $key. No items added." + } + if {$key in $keys_seen} { + error "key '$key' already exists in this collection. No items added." + } + lappend keys_seen $key + } + unset keys_seen + #rely on dict ordering guarantees (post 8.5? preserves order?) + set o_data [dict merge $o_data[set o_data {}] $pairs] + set o_count [dict size $o_data] + } else { + error "patternlib::>collection constructor did not understand arguments supplied. Try a dict as a single argument." + } + array set o_alias [list] + + array set o_bgEnum [list] + @next@ +} +#comment block snipped from collection Constructor + #--------------------------------------------- + #set o_selfID [lindex [set $o_this] 0] ;#object id always available in methods as $_ID_ anyway + # + #### OBSOLETE - left as example of an approach + #make count property traceable (e.g so property ref can be bound to Tk widgets) + #!todo - manually update o_count in relevant methods faster?? + # should avoid trace calls for addList methods, shuffle etc + # + #set handler ::p::${_ID_}::___count_TraceHandler + #proc $handler {_ID_ vname vidx op} { + # #foreach {vname vidx op} [lrange $args end-2 end] {break} + # #! we shouldn't trust this vname - it may be that we are being accessed via upvar so it is a different name + # + # #this is only a 'write' handler + # set ::p::[lindex ${_ID_} 0 0]::o_count [llength [set ::p::[lindex ${_ID_} 0 0]::o_list]] + # return + #} + #trace add variable o_list {write} [list $handler $_ID_] + #### + # + # + #puts "--->collection constructor id: $_ID_" + + + + +set PM [$COL .. PatternMethod .] + + +#!review - why do we need the count method as well as the property? +#if needed - document why. +# read traces on count property can be bypassed by method call... shouldn't we avoid that? +# 2018 - in theory write traces on the . count property are very useful from an application-writer's perpective. +# +$COL .. PatternMethod count {} { + #we don't require any instance vars to be upvar'ed - argless [var] stops them automatically being added. + #we directly refer to the ::O:: var if only accessing a few times rather than upvar'ing. + var o_data + dict size $o_data +} + +$COL .. PatternProperty count +$COL .. PatternPropertyWrite count {_val} { + var + error "count property is read-only" +} + +$COL .. PatternPropertyUnset count {} { + var +} ;#cannot raise error's in unset trace handlers - simply fail to unset silently + +$COL .. PatternMethod isEmpty {} { + #var o_list + #return [expr {[llength $o_list] == 0}] + var o_data + expr {[dict size $o_data] == 0} +} + +$COL .. PatternProperty inverted 0 + + + +###### +# item +###### +#defaults to fifo when no idx supplied (same as 'pair' method). !review? is lifo more logical/intuitive/useful? +# i.e [>obj . item] returns the 1st element in the list +#[>obj . item -1] returns the last element (equiv to "end" keyword used by Tcl list commands) +#[>obj . item -2] returns 2nd last element (equiv to "end-1") + + +$COL .. PatternMethod item {{idx 0}} { + #with pattern::0::$OID access.. was measured faster than item2 : approx 110us vs 140us for 26element collection accessed via string (time {>col $key} 10000) + # (still at least 20 times slower than a plain array... at <5us) + var o_data o_alias + + #!todo - review 'string is digit' vs 'string is integer' ?? + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set keys [dict keys $o_data] + if {[catch {dict get $o_data [lindex $keys $idx]} result]} { + var this + error "no such index : '$idx' in collection: $this" + } else { + return $result + } + } else { + if {[catch {dict get $o_data $idx} result]} { + if {[catch {set o_alias($idx)} nextIdx ]} { + var this + error "no such index: '$idx' in collection: $this" + } else { + #try again + #return $o_array($nextIdx) + #tailcall? + #item $_ID_ $nextIdx + #puts stdout "\n\n\n !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! about to call tailcall item $_ID_ $nextIdx \n\n\n" + tailcall item $_ID_ $nextIdx + } + } else { + return $result + } + } +} + + + +if {0} { +#leave this here for comparison. +$COL .. PatternMethod item2 {{idx 0}} { + var o_array o_list o_alias this + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + + if {[catch {set o_array([lindex $o_list $idx])} result]} { + error "no such index : '$idx' in collection: $this" + } else { + return $result + } + } else { + if {[catch {set o_array($idx)} result]} { + + if {[catch {set o_alias($idx)} nextIdx ]} { + error "no such index: '$idx' in collection: $this" + } else { + #try again + #return $o_array($nextIdx) + item $_ID_ $nextIdx + } + } else { + return $result + } + } + +} +} + +#simple no-frills access for speed.. (timed at 43us vs 63us for item (depending on dispatch method!)) +$COL .. PatternMethod itemNamed {idx} { + var o_data + dict get $o_data $idx +} +$COL .. PatternMethod in {idx} { + var o_data + dict get $o_data $idx +} + +$COL .. PatternMethod itemAt {idx} { + var o_data + dict get $o_data [lindex [dict keys $o_data] $idx] +} + +$COL .. PatternMethod replace {idx val} { + var o_data o_alias this + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + + if {[catch {dict set o_data [lindex [dict keys $o_data] $idx] $val}]} { + error "no such index: '$idx' in collection: $this" + } else { + return $val + } + } else { + if {[catch {dict set o_data $idx $val}]} { + if {[catch {set o_alias($idx)} nextIdx ]} { + error "no such index: '$idx' in collection: $this" + } else { + #try again + tailcall replace $_ID_ $nextIdx $val + } + + } else { + return $val + } + } +} + +#if the supplied index is an alias, return the underlying key; else return the index supplied. +$COL .. PatternMethod realKey {idx} { + var o_alias + + if {[catch {set o_alias($idx)} key]} { + return $idx + } else { + return $key + } +} + +#note alias feature is possibly ill-considered. +#if we delete an item - should we delete corresponding alias? If not - we then would need to allow adding under an alias only if the corresponding key is missing. +$COL .. PatternMethod alias {newAlias existingKeyOrAlias} { + var o_alias + + #set existingKey [realKey $_ID_ $existingKeyOrAlias] + #alias to the supplied KeyOrAlias - not the underlying key + + if {[string is integer -strict $newAlias]} { + error "collection key alias cannot be integer" + } + + if {[string length $existingKeyOrAlias]} { + set o_alias($newAlias) $existingKeyOrAlias + } else { + unset o_alias($newAlias) + } +} +$COL .. PatternMethod aliases {{key ""}} { + var o_alias + + if {[string length $key]} { + set result [list] + #lsearch -stride? + foreach {n v} [array get o_alias] { + if {$v eq $key} { + lappend result $n $v + } + } + + return $result + } else { + return [array get o_alias] + } +} + +#'pop' & 'unshift' methods !todo - optimize so lsearch not called when numerical idx/posn already supplied + +#default to removing item from the end, otherwise from supplied index (position or key) +#!todo - accept alias indices +#!todo - review.. should any corresponding alias be destroyed when the corresponding item is popped (or removed in any way?) +#!todo - review.. for performance.. shouldn't pop NOT accept an index? +#if we need to pop from other than the end.. this could be a separate function. Do other langs use pop with an index?? +$COL .. PatternMethod pop {{idx ""}} { + var o_data o_count + + if {$idx eq ""} { + set key [lindex [dict keys $o_data] end] + } else { + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + } + set posn [lsearch -exact [dict keys $o_data] $key] + + if {($posn >= 0) && ($posn < [dict size $o_data])} { + set result [dict get $o_data $key] + dict unset o_data $key + set o_count [dict size $o_data] + return $result + } else { + error "no such index: '$idx'" + } +} +$COL .. PatternMethod poppair {} { + var o_data o_count + set key [lindex [dict keys $o_data] end] + set val [dict get $o_data $key] + dict unset o_data $key + set o_count [dict size $o_data] + return [list $key $val] +} + + + +#!todo - add 'push' method... (basically specialized versions of 'add') +#push - add at end (effectively an alias for add) +#shift - add at start ???bad name? this is completely at odds with for example the common Perl shift function, which returns and removes the first element of an array. +#add - add at end + +#ordered +$COL .. PatternMethod items {} { + var o_data + + dict values $o_data +} + + + + +#### +#pair +#### +#fifo-style accesss when no idx supplied (likewise with 'add' method) +$COL .. PatternMethod pair {{idx 0}} { + var o_data + + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + + if {[catch {dict get $o_data $key} val]} { + error "no such index: '$idx'" + } else { + return [list $key $val] + } +} +$COL .. PatternMethod pairs {} { + var o_data + set o_data +} + +$COL .. PatternMethod get {} { + var o_data + set o_data +} +#todo - fix >pattern so that methods don't collide with builtins +#may require change to use oo - or copy 'my' mechanism to call own methods +$COL .. PatternMethod Info {} { + var o_data + return [dict info $o_data] +} +#2006-05-21.. args to add really should be in key, value order? +# - this the natural order in array-like lists +# - however.. key should be optional. + +$COL .. PatternMethod add {val args} { + #(using args instead of {key ""} enables use of empty string as a key ) + + var o_data o_alias o_count this + + if {![llength $args]} { + set key "_[::patternlib::uniqueKey]_" + } else { + #!todo - could we handle multiple val,key pairs without impacting performance of the common case? + if {[llength $args] > 1} { + error "add method expected 'val' and optional 'key' - got: $val $args" + + } + + set key [lindex $args 0] + if {[string is integer -strict $key]} { + error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + } + + if {[dict exists $o_data $key]} { + #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" + error "key '$key' already exists in collection $this" + } + if {[info exists o_alias($key)]} { + if {[dict exists $o_data $o_alias($key)]} { + #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias + error "key '$key' already exists as an alias for $o_alias($key) in collection $this" + } + } + + dict set o_data $key $val + + + set posn $o_count + incr o_count + + return $posn +} + + +#should the 'stack' methods such as shift,push,pop,peek actually be on a separate interface? +#what then of methods like 'count' which apply equally well to collections and stacks? + +#Alias for 'add' - is there a way to alias this to add implementation with zero overhead?? +$COL .. PatternMethod push {val args} { + #(using args instead of {key ""} enables use of empty string as a key ) + + var o_data o_alias o_count this + + if {![llength $args]} { + set key "_[::patternlib::uniqueKey]_" + } else { + #!todo - could we handle multiple val,key pairs without impacting performance of the common case? + if {[llength $args] > 1} { + error "add method expected 'val' and optional 'key' - got: $val $args" + + } + + set key [lindex $args 0] + if {[string is integer -strict $key]} { + error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + } + + if {[dict exists $o_data $key]} { + #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" + error "key '$key' already exists in collection $this" + } + if {[info exists o_alias($key)]} { + if {[dict exists $o_data $o_alias($key)]} { + #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias + error "key '$key' already exists as an alias for $o_alias($key) in collection $this" + } + } + + dict set o_data $key $val + + + set posn $o_count + incr o_count + + return $posn +} + + +#shift/unshift - roughly analogous to those found in Perl & PHP +#unshift adds 1 or more values to the beginning of the collection. +$COL .. PatternMethod unshift {values {keys ""}} { + var o_data o_count + + if {![llength $keys]} { + for {set i 0} {$i < [llength $values]} {incr i} { + lappend keys "_[::patternlib::uniqueKey]_" + } + } else { + #check keys before we insert any of them. + foreach newkey $keys { + if {[string is integer -strict $newkey]} { + error "cannot accept key '$newkey', >collection keys must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + } + } + if {[llength $values] != [llength $keys]} { + error "unshift requires same number of keys as values. (or no keys for auto-generated keys) Received [llength $values] values, [llength $keys] keys" + } + + #separate loop through keys because we want to fail the whole operation if any are invalid. + + set existing_keys [dict keys $o_data] + foreach newkey $keys { + if {$newkey in $exisint_keys} { + #puts stderr "==============> key $key already exists in this collection" + error "key '$newkey' already exists in this collection" + } + } + + + #ok - looks like entire set can be inserted. + set newpairs [list] + foreach val $values key $keys { + lappend newpairs $key $val + } + set o_data [concat $newpairs $o_data[set o_data {}]] + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} + +#default to removing item from the beginning, otherwise from supplied index (position or key) +#!todo - accept alias indices +$COL .. PatternMethod shift {{idx ""}} { + var o_data o_count + + if {$idx eq ""} { + set key [lindex [dict keys $o_data] 0] + } else { + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + } + set posn [lsearch -exact [dict keys $o_data] $key] + + if {($posn >= 0) && (($posn/2) < [dict size $o_data])} { + set result [dict get $o_data $key] + dict unset o_data $key + set o_count [dict size $o_data] + return $result + } else { + error "no such index: '$idx'" + } +} + + +$COL .. PatternMethod peek {} { + var o_data + + #set o_array([lindex $o_list end]) + + #dict get $o_data [lindex [dict keys $o_data] end] + lindex $o_data end +} + +$COL .. PatternMethod peekKey {} { + var o_data + #lindex $o_list end + lindex $o_data end-1 +} + + +$COL .. PatternMethod insert {val args} { + var o_data o_count + + set idx 0 + set key "" + + if {[llength $args] <= 2} { + #standard arg (ordered) style: + #>obj . insert $value $position $key + + lassign $args idx key + } else { + #allow for literate programming style: + #e.g + # >obj . insert $value at $listPosition as $key + + if {[catch {array set iargs $args}]} { + error "insert did not understand argument list. +usage: +>obj . insert \$val \$position \$key +>obj . insert \$val at \$position as \$key" + } + if {[info exists iargs(at)]} { + set idx $iargs(at) + } + if {[info exists iargs(as)]} { + set key $iargs(as) + } + } + + if {![string length $key]} { + set key "_[::patternlib::uniqueKey]_" + } + + if {[string is integer -strict $key]} { + error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + + + if {[dict exists $o_data $key]} { + #puts stderr "==============> key $key already exists in this collection" + error "key '$key' already exists in this collection" + } + + if {$idx eq "end"} { + #lappend o_list $key + #standard dict set will add it to the end anyway + dict set o_data $key $val + + } else { + #set o_list [linsert $o_list $idx $key] + + #treat dict as list + set o_data [linsert $o_data[set o_data {}] [expr {$idx*2}] $key $val] + } + + + #set o_array($key) $val + + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} + +#!todo - deprecate and give it a better name! addDict addPairs ? +$COL .. PatternMethod addArray {list} { + var + puts stderr "patternlib::>collection WARNING: addArray deprecated - call addPairs with same argument instead" + tailcall addPairs $_ID_ $list +} +$COL .. PatternMethod addPairs {list} { + var o_data o_alias o_count + if {[llength $list] % 2} { + error "must supply an even number of elements" + } + + set aliaslist [array names o_alias] + #set keylist [dict keys $o_data] + foreach newkey [dict keys $list] { + if {[string is integer -strict $newkey] } { + error ">collection key must be non-integer. Bad key: $newkey. No items added." + } + + #if {$newkey in $keylist} {} + #for small to medium collections - testing for newkey in $keylist is probably faster, + # but we optimise here for potentially large existing collections, where presumably a dict exists lookup will be more efficient. + if {[dict exists $o_data $newkey]} { + error "key '$newkey' already exists in this collection. No items added." + } + #The assumption is that there are in general relatively few aliases - so a list test is appropriate + if {$newkey in $aliaslist} { + if {[dict exists $o_data $o_alias($newkey)]} { + error "key '$newkey' already exists as an alias for $o_alias($newkey) in collection. No items added " + } + } + #! check if $list contains dups? + #- slows method down - for little benefit? + } + #!todo - test? (but we need a loop to test for integer keys.. so what's the point?) + #set intersection [struct::set intersect [dict keys $list] [dict keys $o_data]] + #if {[llength $intersection]} { + # error "keys '$intersection' already present in this collection. No items added." + #} + + + #rely on dict ordering guarantees (post 8.5? preserves order?) + set o_data [dict merge $o_data[set o_data {}] $list] + + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} +$COL .. PatternMethod addList {list} { + var o_data o_count + + foreach val $list { + dict set o_data "_[::patternlib::uniqueKey]_" $val + #!todo - test. Presumably lappend faster because we don't need to check existing keys.. + #..but.. is there shimmering involved in treating o_data as a list? + #lappend o_data _[::patternlib::uniqueKey]_ $val + + #tested 2008-06 tcl8.6a0 lappend was slower as the gain is lost (and more!) during subsequent [dict size $o_data] + } + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} + +#'del' is not a very good name... as we're not really 'deleting' anything. +# 'remove' seems better, and appears to be more consistent with other languages' collection implementations. +#!todo - handle 'endRange' parameter for removing ranges of items. +$COL .. PatternMethod del {idx {endRange ""}} { + var + #!todo - emit a deprecation warning for 'del' + tailcall remove $_ID_ $idx $endRange +} + +$COL .. PatternMethod remove {idx {endRange ""}} { + var o_data o_count o_alias this + + if {[string length $endRange]} { + error "ranged removal not yet implemented.. remove one item at a time." + } + + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + if {[catch {set o_alias($key)} nextKey]} { + error "no such index: '$idx' in collection: $this" + } else { + #try with next key in alias chain... + #return [remove $_ID_ $nextKey] + tailcall remove $_ID_ $nextKey + } + } + } + + dict unset o_data $key + + set o_count [dict size $o_data] + return +} + +#ordered +$COL .. PatternMethod names {{globOrIdx {}}} { + var o_data + + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + #Idx + set idx $globOrIdx + + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + + + + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "no such index : '$idx'" + } else { + return $result + } + + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } +} + +#ordered +$COL .. PatternMethod keys {} { + #like 'names' but without globbing + var o_data + dict keys $o_data +} + +#Unfortunately the string 'name' is highly collidable when mixing in a collection over existing objects +# - !todo - review. Is it worth adjusting the collection methodnames to avoid a few common collision cases? +# - some sort of resolution order/interface-selection is clearly required anyway +# so perhaps it's generally best not to bother being 'polite' here, and implement a robust understandable resolution mechanism. +# In the mean time however... we'll at least avoid 'name'! +# +#$PM name {{posn 0}} { +# var o_array o_list +# +# if {$posn < 0} { +# set posn "end-[expr {abs($posn + 1)}]" +# } +# +# if {[catch {lindex $o_list $posn} result]} { +# error "no such index : '$posn'" +# } else { +# return $result +# } +#} + +$COL .. PatternMethod key {{posn 0}} { + var o_data + + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "no such index : '$posn'" + } else { + return $result + } +} + + +#!todo - consider use of 'end-x' syntax for 'to', and implications re consistency with other commands. +$COL .. PatternMethod setPosn {idx to} { + var o_data + + if {![string is integer -strict $to]} { + error "destination position must be numeric, consider reKey method if you are trying to change the string key under which this value is stored" + } + + if {[string is integer -strict $idx]} { + set idx [expr {$idx % [dict size $o_data]}] + + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + } + + set to [expr {$to % [dict size $o_data]}] + + + set val [dict get $o_data $key] + dict unset o_data $key + + #treat dict as list + set o_data [linsert $o_data[set o_data {}] [expr {$posn*2}] $key $val] + + #set o_list [lreplace $o_list $posn $posn] + #set o_list [linsert $o_list $to $key] + + return $to +} +#!todo - improve efficiency of calls to other functions on this object.. 'inline'?? +#presumably the collection object functionality will be long-term stable because it's purpose is to be a core datastructure; therefore it should be reasonable to favour efficiency over maintainability. +$COL .. PatternMethod incrPosn {idx {by 1}} { + var o_data + if {[string is integer -strict $idx]} { + set idx [expr {$idx % [dict size $o_data]}] + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + } + + set newPosn [expr {($posn + $by) % [dict size $o_data]}] + + setPosn $_ID_ $posn $newPosn + return $newPosn +} +$COL .. PatternMethod decrPosn {idx {by 1}} { + var + return [incrPosn $_ID_ $idx [expr {- $by}]] +} +$COL .. PatternMethod move {idx to} { + var + return [setPosn $_ID_ $idx $to] +} +$COL .. PatternMethod posn {key} { + var o_data + return [lsearch -exact [dict keys $o_data] $key] +} + +#!todo? - disallow numeric values for newKey so as to be consistent with add +#!note! - item can be reKeyed out from under an alias such that the alias chain no longer points to anything +# - this is ok. +$COL .. PatternMethod reKey {idx newKey} { + var o_data o_alias + + + if {[dict exists $o_data $newKey]} { + #puts stderr "==============> reKey collision, key $newKey already exists in this collection" + error "reKey collision, key '$newKey' already exists in this collection" + } + if {[info exists o_alias($newKey)]} { + if {[dict exists $o_data $o_alias($newKey)]} { + error "reKey collision, key '$newKey' already present as an alias in this collection" + } else { + set newKey $o_alias($newKey) + } + } + + + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + if {[catch {set o_alias($key)} nextKey]} { + error "no such index: '$idx'" + } else { + #try with next key in alias chain... + #return [reKey $_ID_ $nextKey $newKey] + tailcall reKey $_ID_ $nextKey $newKey + } + } + } + + #set o_list [lreplace $o_list $posn $posn $newKey] + ##atomic? (traces on array?) + #set o_array($newKey) $o_array($key) + #unset o_array($key) + + dict set o_data $newKey [dict get $o_data $key] + dict unset o_data $key + + return +} +$COL .. PatternMethod hasKey {key} { + var o_data + dict exists $o_data $key +} +$COL .. PatternMethod hasAlias {key} { + var o_alias + info exists o_alias($key) +} + +#either key or alias +$COL .. PatternMethod hasIndex {key} { + var o_data o_alias + if {[dict exists $o_data $key]} { + return 1 + } else { + return [info exists o_alias($key)] + } +} + + +#Shuffle methods from http://mini.net/tcl/941 +$COL .. PatternMethod shuffleFast {} { + #shuffle6 - fast, but some orders more likely than others. + + var o_data + + set keys [dict keys $o_data] + + set n [llength $keys] + for { set i 1 } { $i < $n } { incr i } { + set j [expr { int( rand() * $n ) }] + set temp [lindex $keys $i] + lset keys $i [lindex $keys $j] + lset keys $j $temp + } + + #rebuild dict in new order + #!todo - can we do the above 'in place'? + set newdata [dict create] + foreach k $keys { + dict set newdata $k [dict get $o_data $k] + } + set o_data $newdata + + return +} +$COL .. PatternMethod shuffle {} { + #shuffle5a + + var o_data + + set n 1 + set keys [list] ;#sorted list of keys + foreach k [dict keys $o_data] { + #set index [expr {int(rand()*$n)}] + + #set slist [linsert [::pattern::K $keys [set keys {}]] $index $k] + + #faster alternative.. 'inline K' [lindex [list a b] 0] ~ [K a b] + set keys [linsert [lindex [list $keys [set keys {}]] 0] [expr {int(rand()*$n)}] $k] + incr n + } + + #rebuild dict in new order + #!todo - can we do the above 'in place'? + set newdata [dict create] + foreach k $keys { + dict set newdata $k [dict get $o_data $k] + } + set o_data $newdata + + return +} + + +#search is a somewhat specialised form of 'itemKeys' +$COL .. PatternMethod search {value args} { + var o_data + #only search on values as it's possible for keys to match - especially with options such as -glob + set matches [lsearch {*}$args [dict values $o_data] $value] + + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) * 2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } +} + +#inverse lookup +$COL .. PatternMethod itemKeys {value} { + var o_data + #only search on values as it's possible for keys to match + set value_indices [lsearch -all [dict values $o_data] $value] + + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) * 2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist +} + +#invert: +#change collection to be indexed by its values with the old keys as new values. +# - keys of duplicate values become a list keyed on the value. +#e.g the array equivalent is: +# arr(a) 1 +# arr(b) 2 +# arr(c) 2 +#becomes +# inv(1) a +# inv(2) {b c} +#where the order of duplicate-value keys is not defined. +# +#As the total number of keys may change on inversion - order is not preserved if there are ANY duplicates. +# + + +#!todo - try just [lreverse $o_data] ?? + + +$COL .. PatternMethod invert {{splitvalues ""}} { + + var o_data o_count o_dupes o_inverted + + + if {$splitvalues eq ""} { + #not overridden - use o_dupes from last call to determine if values are actually keylists. + if {$o_dupes > 0} { + set splitvalues 1 + } else { + set splitvalues 0 + } + } + + + #set data [array get o_array] + set data $o_data + + if {$o_count > 500} { + #an arbitrary optimisation for 'larger' collections. + #- should theoretically keep the data size and save some reallocations. + #!todo - test & review + # + foreach nm [dict keys $o_data] { + dict unset o_data $nm + } + } else { + set o_data [dict create] + } + + if {!$splitvalues} { + dict for {k v} $data { + dict set o_data $v $k + } + } else { + dict for {k v} $data { + #we're splitting values because each value is a list of keys + #therefore sub should be unique - no need for lappend in this branch. + foreach sub $v { + #if {[info exists o_array($sub)]} { + # puts stderr "---here! v:$v sub:$sub k:$k" + # lappend o_array($sub) $k + #} else { + dict set o_data $sub $k + #} + } + } + } + + + if {[dict size $o_data] != $o_count} { + #must have been some dupes + + set o_dupes [expr {$o_count - [dict size $o_data]}] + #update count to match inverted collection + set o_count [dict size $o_data] + } else { + set o_dupes 0 + } + + set o_inverted [expr {!$o_inverted}] + + #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' + return $o_dupes +} + + + + + + +#NOTE: values are treated as lists and split into separate keys for inversion only if requested! +# To treat values as keylists - set splitvalues 1 +# To treat each value atomically - set splitvalues 0 +# i.e only set splitvalues 1 if you know the values represent duplicate keys from a previous call to invert! +# +# +#Initially call invert with splitvalues = 0 +#To keep calling invert and get back where you started.. +# The rule is... if the previous call to invert returned > 0... pass 1 on the next call. +# +$COL .. PatternMethod invert_manual {{splitvalues 0}} { + #NOTE - the list nesting here is *tricky* - It probably isn't broken. + + var o_list o_array o_count + + set data [array get o_array] + + if {$o_count > 500} { + #an arbitrary optimisation for 'large' collections. + #- should theoretically keep the array size and save some reallocations. + #!todo - test & review + # + foreach nm [array names o_array] { + unset o_array($nm) + } + } else { + array unset o_array + } + + if {!$splitvalues} { + foreach {k v} $data { + lappend o_array($v) $k + } + } else { + foreach {k v} $data { + #we're splitting values because each value is a list of keys + #therefore sub should be unique - no need for lappend in this branch. + foreach sub $v { + #if {[info exists o_array($sub)]} { + # puts stderr "---here! v:$v sub:$sub k:$k" + # lappend o_array($sub) $k + #} else { + set o_array($sub) $k + #} + } + } + } + + + if {[array size o_array] != $o_count} { + #must have been some dupes + set o_list [array names o_array] + + + set dupes [expr {$o_count - [array size o_array]}] + #update count to match inverted collection + set o_count [array size o_array] + } else { + #review - are these machinations worthwhile for order preservation? what speed penalty do we pay? + array set prev $data + set i -1 + if {$splitvalues} { + #values are lists of length one. Take lindex 0 so list values aren't overnested. + foreach oldkey $o_list { + lset o_list [incr i] [lindex $prev($oldkey) 0] + } + } else { + foreach oldkey $o_list { + lset o_list [incr i] $prev($oldkey) + } + } + + set dupes 0 + } + + + #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' + return $dupes +} + + + +#Note that collections cannot be inverted without loss of information if they have duplicates AND compound keys +# (keys that are lists) +$COL .. PatternMethod invert_lossy {{splitvalues 1}} { + var o_list o_array o_count + + set data [array get o_array] + + if {$o_count > 500} { + #an arbitrary optimisation for 'large' collections. + #- should theoretically keep the array size and save some reallocations. + #!todo - test & review + # + foreach nm [array names o_array] { + unset o_array($nm) + } + } else { + array unset o_array + } + + if {!$splitvalues} { + foreach {k v} $data { + #note! we must check for existence and use 'set' for first case. + #using 'lappend' only will result in deeper nestings on each invert! + #If you don't understand this - don't change it! + if {[info exists o_array($v)]} { + lappend o_array($v) $k + } else { + set o_array($v) $k + } + } + } else { + foreach {k v} $data { + #length test necessary to avoid incorrect 'un-nesting' + #if {[llength $v] > 1} { + foreach sub $v { + if {[info exists o_array($sub)]} { + lappend o_array($sub) $k + } else { + set o_array($sub) $k + } + } + #} else { + # if {[info exists o_array($v)]} { + # lappend o_array($v) $k + # } else { + # set o_array($v) $k + # } + #} + } + } + + + if {[array size o_array] != $o_count} { + #must have been some dupes + set o_list [array names o_array] + + + set dupes [expr {$o_count - [array size o_array]}] + #update count to match inverted collection + set o_count [array size o_array] + } else { + #review - are these machinations worthwhile for order preservation? what speed penalty do we pay? + array set prev $data + set i -1 + foreach oldkey $o_list { + lset o_list [incr i] $prev($oldkey) + } + set dupes 0 + } + + + #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' + return $dupes +} + +$COL .. PatternMethod reverse {} { + var o_data + + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return +} + +$COL .. PatternMethod keySort {{options -ascii}} { + var o_data + + set keys [lsort {*}$options [dict keys $o_data]] + + set dictnew [dict create] + foreach k $keys { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + + return +} + +#!todo - allow simple options in combination with options such as -command and -object. Redo args handling completely for more complex sorting. +$COL .. PatternMethod sort {args} { + var o_data + + #defaults + set options [dict create -index 1] ;#values always in subelement 1 of name-value pair list for sorting. + + set options_simple [list] + + + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + switch -- $a { + -indices - + -ascii - + -dictionary - + -integer - + -real - + -increasing - + -decreasing { + #dict set options $a 1 + lappend options_simple $a + } + -unique { + #not a valid option + #this would stuff up the data... + #!todo? - remove dups from collection if this option used? - alias the keys? + } + -object { + #!todo - treat value as object and allow sorting by sub-values .eg >col1 . sort -object ". sub . property" -increasing + #may be slow - but handy. Consider -indexed property to store/cache these values on first run + } + -command { + dict set options $a [lindex $args [incr i]] + } + -index { + #allow sorting on subindices of the value. + dict set options -index [concat [dict get $options -index] [lindex $args [incr i]] ] + } + default { + #unrecognised option - print usage? + } + } + } + + + + if {[set posn [lsearch -exact $options_simple "-indices"]] >= 0} { + + var o_array + + set slist [list] + foreach k [dict keys $o_data] { + lappend slist [list $k [dict get $o_data $k]] + } + return [lsort {*}$options_simple {*}$options $slist] + + + + #set options_simple [lreplace $options_simple $posn $posn] ;# + #set slist [list] + #foreach {n v} [array get ::p::[lindex ${_ID_} 0 0]::o_array] { + # lappend slist [list $n $v] + #} + #set slist [lsort {*}$options_simple {*}$options $slist] + #foreach i $slist { + # #determine the position in the collections list + # lappend result {*}[lsearch -exact $o_list [lindex $i 0]] + #} + #return $result + } else { + set slist [list] + dict for {k v} $o_data { + lappend slist [list $k $v] + } + #set slist [lsort {*}$options_simple {*}$options $slist] + set slist [lsort {*}$options_simple {*}$options $slist[set slist {}]] ;#K combinator for efficiency + + + #set o_list [lsearch -all -inline -subindices -index 0 $slist *] + + set o_data [dict create] + foreach pair $slist { + dict set o_data [lindex $pair 0] [lindex $pair 1] + } + + + + return + } + +} + + +$COL .. PatternMethod clear {} { + var o_data o_count + + set o_data [dict create] + set o_count 0 + #aliases? + return +} + +#see http://wiki.tcl.tk/15271 - A generic collection traversal interface +# +#!todo - options: -progresscommand -errorcommand (-granularity ?) (-self ? (to convert to an iterator?)) +#!todo? - lazy retrieval of items so that all changes to the collection are available to a running asynch enumeration? +# - should this be an option? which mechanism should be the default? +# - currently only the keylist is treated in 'snapshot' fashion +# so values could be changed and the state could be invalidated by other code during an enumeration +# +$COL .. PatternMethod enumerate {args} { + #---------- + lassign [lrange $args end-1 end] cmd seed + set optionlist [list] + foreach a [lrange $args 0 end-2] { + lappend optionlist $a + } + set opt(-direction) left + set opt(-completioncommand) "" + array set opt $optionlist + #---------- + var o_data + + if {[string tolower [string index $opt(-direction) 0]] eq "r"} { + #'right' 'RIGHT' 'r' etc. + set list [lreverse [dict keys $o_data]] + } else { + #normal left-right order + set list [dict keys $o_data] + } + + if {![string length $opt(-completioncommand)]} { + #standard synchronous processing + foreach k $list { + set seed [uplevel #0 [list {*}$cmd $seed [dict get $o_data $k]]] + } + return $seed + } else { + #ASYNCHRONOUS enumeration + var this o_bgEnum + #!todo - make id unique + #!todo - facility to abort running enumeration. + set enumID enum[array size o_bgEnum] + + set seedvar [$this . bgEnum $enumID .] + set $seedvar $seed + + after 0 [list $this . _doBackgroundEnum $enumID $list $cmd $seedvar $opt(-completioncommand)] + return $enumID + } +} + +#!todo - make private? - put on a separate interface? +$COL .. PatternMethod _doBackgroundEnum {enumID slice cmd seedvar completioncommand} { + var this o_data + + + #Note that we don't post to the eventqueue using 'foreach s $slice' + # we only schedule another event after each item is processed + # - otherwise we would be spamming the eventqueue with items. + + #!todo? - accept a -granularity option to allow handling of n list-items per event? + + if {[llength $slice]} { + set slice [lassign $slice head] + + set script [string map [list %cmd% $cmd %seedvar% $seedvar %val% [dict get $o_data $head]] { + %cmd% [set %seedvar%] %val% + }] + + #post to eventqueue and re-enter _doBackgroundEnum + # + after idle [list after 0 [subst {set $seedvar \[uplevel #0 [list $script] \]; $this . _doBackgroundEnum $enumID [list $slice] [list $cmd] $seedvar [list $completioncommand]}]] + + } else { + #done. + + set script [string map [list %cmd% $completioncommand %seedvar% $seedvar] { + lindex [list [%cmd% [set %seedvar%]] [unset %seedvar%]] 0 + }] + + after idle [list after 0 [list uplevel #0 $script]] + } + + return +} + +$COL .. PatternMethod enumeratorstate {} { + var o_bgEnum + parray o_bgEnum +} + +#proc ::bgerror {args} { +# puts stderr "=bgerror===>$args" +#} + + +#map could be done in terms of the generic 'enumerate' method.. but it's slower. +# +#$PM map2 {proc} { +# var +# enumerate $_ID_ [list ::map-helper $proc] [list] +#} +#proc ::map-helper {proc accum item} { +# lappend accum [uplevel #0 [list {*}$proc $item]] +#} + +$COL .. PatternMethod map {cmd} { + var o_data + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + + return $seed +} +$COL .. PatternMethod objectmap {cmd} { + var o_data + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + + return $seed +} + + +#End core collection functionality. +#collection 'mixin' interfaces + +>pattern .. Create >keyvalprotector +>keyvalprotector .. PatternVariable o_protectedkeys +>keyvalprotector .. PatternVariable o_protectedvals + +#!todo - write test regarding errors in Constructors for mixins like this +# - an error (e.g from bad args) can cause errors with vars after it's re-run with correct args +>keyvalprotector .. Constructor {args} { + var this o_protectedkeys o_protectedvals + set this @this@ + #---------------------------------------------------------------------------- + set known_opts [list -keys -vals ] + dict set default -keys [list] + dict set default -vals [list] + if {([llength $args] % 2) != 0} { + error "(>keyvalprotector .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "(>keyvalprotector .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set o_protectedkeys [dict get $opts -keys] + set o_protectedvals [dict get $opts -vals] + #---------------------------------------------------------------------------- + set protections [concat $o_protectedkeys $o_protectedvals] + if {![llength $protections]} { + error "(>keyvalprotector .. Constructor) ERROR: must supply at least one argument to -vals or -keys" + } + +} +>keyvalprotector .. PatternMethod clear {} { + error "(>keyvalprotector . clear) ERROR: This collection is protected by a >keyvalprotector mixin. Cannot clear" +} +>keyvalprotector .. PatternMethod pop {{idx ""}} { + var o_data o_count o_protectedkeys o_protectedvals + + if {$idx eq ""} { + set key [lindex [dict keys $o_data] end] + } else { + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + } + + if {$key in $o_protectedkeys} { + error "(>keyvalprotector . pop) ERROR: Cannot pop object with index '$idx', key '$key' from collection." + } + set posn [lsearch -exact [dict keys $o_data] $key] + if {($posn >= 0) && ($posn < [dict size $o_data])} { + set result [dict get $o_data $key] + if {$result in $o_protectedvals} { + error "(>keyvalprotector . pop) ERROR: Cannot pop object '$result' with index '$idx', key '$key' from collection." + } + dict unset o_data $key + set o_count [dict size $o_data] + return $result + } else { + error "no such index: '$idx'" + } + +} +>keyvalprotector .. PatternMethod remove {idx {endRange ""}} { + var this o_data o_count o_alias o_protectedkeys o_protectedvals + + if {[string length $endRange]} { + error "ranged removal not yet implemented.. remove one item at a time." + } + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set key [lindex [dict keys $o_data] $idx] + if {$key in $o_protectedkeys} { + error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' key '$key' from collection" + } + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + if {[catch {set o_alias($key)} nextKey]} { + error "no such index: '$idx' in collection: $this" + } else { + if {$key in $o_protectedkeys} { + error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' from collection" + } + #try with next key in alias chain... + #return [remove $_ID_ $nextKey] + tailcall remove $_ID_ $nextKey + } + } + } + + dict unset o_data $key + + set o_count [dict size $o_data] + return +} + +#1) +#predicate methods (order preserving) +#usage: +# >collection .. Create >c1 +# >predicatedCollection .. Create >c1 ;#overlay predicate methods on existing collection + +#e.g >col1 . all {$val > 14} +#e.g >col1 . filterToCollection {$val > 19} . count +#e.g >col1 . filter {[string match "x*" $key]} +#!todo - fix. currying fails.. + +::>pattern .. Create >predicatedCollection +#process_pattern_aliases ::patternlib::>predicatedCollection + +set PM [>predicatedCollection .. PatternMethod .] + +>predicatedCollection .. PatternMethod filter {predicate} { + var this o_list o_array + set result [list] + + #!note (jmn 2004) how could we do smart filtering based on $posn? + #i.e it would make sense to lrange $o_list based on $posn... + #but what about complicated expressions where $posn is a set of ranges and/or combined with tests on $key & $val ?? + #Seems better to provide an alternative efficient means of generating subcolllections/ranges to perform predicate operations upon. + #given this, is $posn even useful? + + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + lappend result $val + } + incr posn + } + set result +} +>predicatedCollection .. PatternMethod filterToKeys {predicate} { + var this o_list o_array + set result [list] + + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + lappend result $key + } + incr posn + } + set result +} +>predicatedCollection .. PatternMethod filterToCollection {predicate {destCollection {}}} { + #!todo - collection not in subordinate namespace? -> if subordinate, should imply modification of sub's contents will be reflected in parent? + #!todo - implement as 'view' on current collection object.. extra o_list variables? + #!todo - review/document 'expected' key collision behaviour - source keys used as dest keys.. -autokey option required? + var this o_list o_array m_i_filteredCollection + + incr m_i_filteredCollection + if {![string length $destCollection]} { + #!todo? - implement 'one-shot' object (similar to RaTcl) + set result [::patternlib::>collection .. Create [$this .. Namespace]::>filteredCollection-$m_i_filteredCollection] + } else { + set result $destCollection + } + + #### + #externally manipulate new collection + #set ADD [$c . add .] + #foreach key $o_list { + # set val $o_array($key) + # if $predicate { + # $ADD $val $key + # } + #} + ### + + #internal manipulation faster + #set cID [lindex [set $result] 0] + set cID [lindex [$result --] 0] + + #use list to get keys so as to preserve order + set posn 0 + upvar #0 ::p::${cID}::o_array cARRAY ::p::${cID}::o_list cLIST + foreach key $o_list { + set val $o_array($key) + if $predicate { + if {[info exists cARRAY($key)]} { + error "key '$key' already exists in this collection" + } + lappend cLIST $key + set cARRAY($key) $val + } + incr posn + } + + return $result +} + +#NOTE! unbraced expr/if statements. We want to evaluate the predicate. +>predicatedCollection .. PatternMethod any {predicate} { + var this o_list o_array + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + return 1 + } + incr posn + } + return 0 +} +>predicatedCollection .. PatternMethod all {predicate} { + var this o_list o_array + set posn 0 + foreach key $o_list { + set val $o_array($key) + if !($predicate) { + return 0 + } + incr posn + } + return 1 +} +>predicatedCollection .. PatternMethod dropWhile {predicate} { + var this o_list o_array + set result [list] + set _idx 0 + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + incr _idx + } else { + break + } + incr posn + } + set remaining [lrange $o_list $_idx end] + foreach key $remaining { + set val $o_array($key) + lappend result $val + } + return $result +} +>predicatedCollection .. PatternMethod takeWhile {predicate} { + var this o_list o_array + set result [list] + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + lappend result $val + } else { + break + } + incr posn + } + set result +} + + + +#end >collection mixins +###################################### + + + + +#----------------------------------------------------------- +#!TODO - methods for converting an arrayHandle to & from a hashMap efficiently? +# Why do we need both? apart from the size variable, what is the use of hashMap? +#----------------------------------------------------------- +#::pattern::create >hashMap +::>pattern .. Create >hashMap + +>hashMap .. PatternVariable o_size +>hashMap .. PatternVariable o_array + +>hashMap .. Constructor {args} { + var o_array o_size + array set o_array [list] + set o_size 0 +} +>hashMap .. PatternDefaultMethod "item" +>hashMap .. PatternMethod item {key} { + var o_array + set o_array($key) +} +>hashMap .. PatternMethod items {} { + var o_array + + set result [list] + foreach nm [array names o_array] { + lappend result $o_array($nm) + } + return $result +} +>hashMap .. PatternMethod pairs {} { + var o_array + + array get o_array +} +>hashMap .. PatternMethod add {val key} { + var o_array o_size + + set o_array($key) $val + incr o_size + return $key +} + +>hashMap .. PatternMethod del {key} { + var + puts stderr "warning: 'del' method of >hashMap deprecated. Use 'remove' instead." + remove $_ID_ $key +} +>hashMap .. PatternMethod remove {key} { + var o_array o_size + unset o_array($key) + incr o_size -1 + return $key +} +>hashMap .. PatternMethod count {} { + var o_size + #array size o_array + return $o_size +} +>hashMap .. PatternMethod count2 {} { + var o_array + #array size o_array ;#slow, at least for TCLv8.4.4 + #even array statistics is faster than array size ! + #e.g return [lindex [array statistics o_array] 0] + #but.. apparently there are circumstances where array statistics doesn't report the correct size. + return [array size o_array] +} +>hashMap .. PatternMethod names {} { + var o_array + array names o_array +} +>hashMap .. PatternMethod keys {} { + #synonym for names + var o_array + array names o_array +} +>hashMap .. PatternMethod hasKey {key} { + var o_array + return [info exists o_array($key)] +} +>hashMap .. PatternMethod clear {} { + var o_array o_size + unset o_array + set o_size 0 + return +} +#>hashMap .. Ready 1 + + + + + + + + + + + + + + + +#explicitly create metadata. Not required for user-defined patterns. +# this is only done here because this object is used for the metadata of all objects +# so the object must have all it's methods/props before its own metadata structure can be built. +#uplevel 1 "::pattern::object ::pattern::>_nullMeta createMetadata >collection" +#uplevel 1 "::patternlib::>collection .. CreateMetadata ::patternlib::>collection" + + + + +if 0 { + + +#----------------------------------------------------------- +#::pattern::create >arrayHandle { +# variable o_arrayName +# variable this +#} +::>pattern .. Create >arrayHandle + +>arrayHandle .. PatternVariable o_arrayName +>arrayHandle .. PatternVariable this + +>arrayHandle .. Constructor {args} { + var o_arrayName this + set this @this@ + + + set o_arrayName [$this .. Namespace]::array + + upvar #0 $o_arrayName $this + #? how to automatically update this after a namespace import? + + array set $o_arrayName [list] + +} +>arrayHandle .. PatternMethod array {} { + var o_arrayName + return $o_arrayName +} + +#------------------------------------------------------- +#---- some experiments +>arrayHandle .. PatternMethod up {varname} { + var o_arrayName + + #is it dodgy to hard-code the calling depth? + #will it be different for different object systems? + #Will it even be consistent for the same object. + # Is this method necessary anyway? - + # - users can always instead do: + # upvar #0 [>instance . array] var + + uplevel 3 [list upvar 0 $o_arrayName $varname] + + return +} +>arrayHandle .. PatternMethod global {varname} { + var o_arrayName + # upvar #0 [>instance . array] var + + if {![string match ::* $varname]} { + set varname ::$varname + } + + upvar #0 $o_arrayName $varname + + return +} +>arrayHandle .. PatternMethod depth {} { + var o_arrayName + # + for {set i 0} {$i < [info level]} { + puts "${i}: [uplevel $i [list namespace current] , [info level $i]]" + } + +} + # -------------------------------------------- + + +>arrayHandle .. PatternMethod item {key} { + var o_arrayName + set ${o_arrayName}($key) +} +>arrayHandle .. PatternMethod items {} { + var o_arrayName + + set result [list] + foreach nm [array names $o_arrayName] { + lappend result [set ${o_arrayName}($nm)] + } + return $result +} +>arrayHandle .. PatternMethod pairs {} { + var o_arrayName + + array get $o_arrayName +} +>arrayHandle .. PatternMethod add {val key} { + var o_arrayName + + set ${o_arrayName}($key) $val + return $key +} +>arrayHandle .. PatternMethod del {key} { + puts stderr "Warning: 'del' method of >arrayHandle deprecated. Use 'remove' instead." + remove $_ID_ $key +} +>arrayHandle .. PatternMethod remove {key} { + var o_arrayName + unset ${o_arrayName}($key) + return $key +} +>arrayHandle .. PatternMethod size {} { + var o_arrayName + return [array size $o_arrayName] +} +>arrayHandle .. PatternMethod count {} { + #alias for size + var o_arrayName + return [array size $o_arrayName] +} +>arrayHandle .. PatternMethod statistics {} { + var o_arrayName + return [array statistics $o_arrayName] +} +>arrayHandle .. PatternMethod names {} { + var o_arrayName + array names $o_arrayName +} +>arrayHandle .. PatternMethod keys {} { + #synonym for names + var o_arrayName + array names $o_arrayName +} +>arrayHandle .. PatternMethod hasKey {key} { + var o_arrayName + + return [info exists ${o_arrayName}($key)] +} +>arrayHandle .. PatternMethod clear {} { + var o_arrayName + unset $o_arrayName + array set $o_arrayName [list] + + return +} +#>arrayHandle .. Ready 1 + + + + +::>pattern .. Create >matrix + +>matrix .. PatternVariable o_array +>matrix .. PatternVariable o_size + +>matrix .. Constructor {args} { + var o_array o_size + + array set o_array [list] + set o_size 0 +} + + +#process_pattern_aliases ::patternlib::>matrix + +set PM [>matrix .. PatternMethod .] + +>matrix .. PatternMethod item {args} { + var o_array + + if {![llength $args]} { + error "indices required" + } else { + + } + if [info exists o_array($args)] { + return $o_array($args) + } else { + error "no such index: '$args'" + } +} +>matrix .. PatternMethod items {} { + var o_array + + set result [list] + foreach nm [array names o_array] { + lappend result $o_array($nm) + } + return $result +} +>matrix .. PatternMethod pairs {} { + var o_array + + array get o_array +} +>matrix .. PatternMethod slice {args} { + var o_array + + if {"*" ni $args} { + lappend args * + } + + array get o_array $args +} +>matrix .. PatternMethod add {val args} { + var o_array o_size + + if {![llength $args]} { + error "indices required" + } + + set o_array($args) $val + incr o_size + + #return [array size o_array] + return $o_size +} +>matrix .. PatternMethod names {} { + var o_array + array names o_array +} +>matrix .. PatternMethod keys {} { + #synonym for names + var o_array + array names o_array +} +>matrix .. PatternMethod hasKey {args} { + var o_array + + return [info exists o_array($args)] +} +>matrix .. PatternMethod clear {} { + var o_array o_size + unset o_array + set o_size 0 + return +} +>matrix .. PatternMethod count {} { + var o_size + return $o_size +} +>matrix .. PatternMethod count2 {} { + var o_array + #see comments for >hashMap count2 + return [array size o_array] +} +#>matrix .. Ready 1 + +#-------------------------------------------------------- +#tree data structure (based *loosely* on API at http://www.msen.com/%7Eclif/treeNobj.html - discussed in Clif Flynts book Tcl programming) +#!todo - compare API to http://tcllib.sourceforge.net/doc/tree.html +#!todo - create an >itree (inheritance tree) where node data is readable/writable on children unless overridden. +::>pattern .. Create >tree + +set _NODE [::>pattern .. Create [>tree .. Namespace]::>node] +set _TREE_NODE $_NODE +#process_pattern_aliases $_TREE_NODE + +$_NODE .. PatternVariable o_treens ;#tree namespace +$_NODE .. PatternVariable o_idref +$_NODE .. PatternVariable o_nodePrototype + +#$_NODE .. PatternProperty data +$_NODE .. PatternProperty info + +$_NODE .. PatternProperty tree +$_NODE .. PatternProperty parent +$_NODE .. PatternProperty children +$_NODE .. PatternMethod addNode {} { + set nd_id [incr $o_idref] + set nd [$o_nodePrototype .. Create ${o_treens}::>n-$nd_id -tree $o_tree -parent @this@] + @this@ . add $nd n-$nd_id + + return n-$nd_id +} +#flat list of all nodes below this +#!todo - something else? ad-hoc collections? +#!todo - non-recursive version? tail-call opt? +$_NODE .. PatternMethod nodes {} { + set result [list] + + #use(abuse?) our knowledge of >collection internals + foreach n $o_list { + #eval lappend result $n [$o_array($n) . nodes] + #!todo - test + lappend result $n {*}[$o_array($n) . nodes] + } + return $result +} +#count of number of descendants +#!todo - non-recursive version? tail-call opt? +$_NODE .. PatternMethod size {} { + set result 0 + #use(abuse?) our knowledge of >collection internals + foreach n $o_list { + incr result [expr {1 + [$o_array($n) . size]}] + } + return $result +} +$_NODE .. PatternMethod isLeaf {} { + #!todo - way to stop unused vars being uplevelled? + var o_tree + + #tailcall isEmpty $_ID_ ;#fails. because isEmpty is from >collection interface - so different ns? + tailcall [@this@ . isEmpty .] +} +$_NODE .. Constructor {args} { + array set A $args + + set o_tree $A(-tree) + set o_parent $A(-parent) + + #array set o_data [list] + array set o_info [list] + + set o_nodePrototype [::patternlib::>tree .. Namespace]::>node + set o_idref [$o_tree . nodeID .] + set o_treens [$o_tree .. Namespace] + #set o_children [::patternlib::>collection .. Create [@this@ .. Namespace]::>children] + + #overlay children collection directly on the node + set o_children [::patternlib::>collection .. Create @this@] + + return +} + +>tree .. PatternProperty test blah +>tree .. PatternProperty nodeID 0 ;#public only so node can access.. need 'friend' concept? +>tree .. PatternVariable o_ns +>tree .. Constructor {args} { + set o_ns [@this@ .. Namespace] + + #>tree is itself also a node (root node) + #overlay new 'root' node onto existing tree, pass tree to constructor + [::patternlib::>tree .. Namespace]::>node .. Create @this@ -tree @this@ -parent "" +} + + + + +unset _NODE + + + + +#-------------------------------------------------------- +#a basic binary search tree experiment +# - todo - 'scheme' property to change behaviour? e.g balanced tree +::>pattern .. Create >bst +#process_pattern_aliases ::patternlib::>bst +>bst .. PatternVariable o_NS ;#namespace +>bst .. PatternVariable o_this ;#namespace +>bst .. PatternVariable o_nodeID + +>bst .. PatternProperty root "" +>bst .. Constructor {args} { + set o_this @this@ + set o_NS [$o_this .. Namespace] + namespace eval ${o_NS}::nodes {} + puts stdout ">bst constructor" + set o_nodeID 0 +} +>bst .. PatternMethod insert {key args} { + set newnode [::patternlib::>bstnode .. Create ${o_NS}::nodes::>n-[incr o_nodeID]] + set [$newnode . key .] $key + if {[llength $args]} { + set [$newnode . value .] $args + } + if {![string length $o_root]} { + set o_root $newnode + set [$newnode . parent .] $o_this + } else { + set ipoint {} ;#insertion point + set tpoint $o_root ;#test point + set side {} + while {[string length $tpoint]} { + set ipoint $tpoint + if {[$newnode . key] < [$tpoint . key]} { + set tpoint [$tpoint . left] + set side left + } else { + set tpoint [$tpoint . right] + set side right + } + } + set [$newnode . parent .] $ipoint + set [$ipoint . $side .] $newnode + } + return $newnode +} +>bst .. PatternMethod item {key} { + if {![string length $o_root]} { + error "item $key not found" + } else { + set tpoint $o_root + while {[string length $tpoint]} { + if {[$tpoint . key] eq $key} { + return $tpoint + } else { + if {$key < [$tpoint . key]} { + set tpoint [$tpoint . left] + } else { + set tpoint [$tpoint . right] + } + } + } + error "item $key not found" + } +} +>bst .. PatternMethod inorder-walk {} { + if {[string length $o_root]} { + $o_root . inorder-walk + } + puts {} +} +>bst .. PatternMethod view {} { + array set result [list] + + if {[string length $o_root]} { + array set result [$o_root . view 0 [list]] + } + + foreach depth [lsort [array names result]] { + puts "$depth: $result($depth)" + } + +} +::>pattern .. Create >bstnode +#process_pattern_aliases ::patternlib::>bstnode +>bstnode .. PatternProperty parent +>bstnode .. PatternProperty left "" +>bstnode .. PatternProperty right "" +>bstnode .. PatternProperty key +>bstnode .. PatternProperty value + +>bstnode .. PatternMethod inorder-walk {} { + if {[string length $o_left]} { + $o_left . inorder-walk + } + + puts -nonewline "$o_key " + + if {[string length $o_right]} { + $o_right . inorder-walk + } + + return +} +>bstnode .. PatternMethod view {depth state} { + #!todo - show more useful representation of structure + set lower [incr depth] + + if {[string length $o_left]} { + set state [$o_left . view $lower $state] + } + + if {[string length $o_right]} { + set state [$o_right . view $lower $state] + } + + + array set s $state + lappend s($depth) $o_key + + return [array get s] +} + + +#-------------------------------------------------------- +#::pattern::create ::pattern::>metaObject +#::pattern::>metaObject PatternProperty methods +#::pattern::>metaObject PatternProperty properties +#::pattern::>metaObject PatternProperty PatternMethods +#::pattern::>metaObject PatternProperty patternProperties +#::pattern::>metaObject Constructor args { +# set this @this@ +# +# set [$this . methods .] [::>collection create [$this namespace]::methods] +# set [$this . properties .] [::>collection create [$this namespace]::properties] +# set [$this . PatternMethods .] [::>collection create [$this namespace]::PatternMethods] +# set [$this . patternProperties .] [::>collection create [$this namespace]::patternProperties] +# +#} + + + + #tidy up + unset PV + unset PM + + + +#-------------------------------------------------------- +::>pattern .. Create >enum +#process_pattern_aliases ::patternlib::>enum +>enum .. PatternMethod item {{idx 0}} { + var o_array o_list + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {set o_array([lindex $o_list $idx])} result]} { + error "no such index : '$idx'" + } else { + return $result + } + } else { + if {[catch {set o_array($idx)} result]} { + error "no such index: '$idx'" + } else { + return $result + } + } +} + + + +#proc makeenum {type identifiers} { +# #!!todo - make generated procs import into whatever current system context? +# +# upvar #0 wbpbenum_${type}_number a1 wbpbenum_number_${type} a2 +# +# #obliterate any previous enum for this type +# catch {unset a1} +# catch {unset a2} +# +# set n 0 +# foreach id $identifiers { +# set a1($id) $n +# set a2($n) $id +# incr n +# } +# proc ::${type}_to_number key [string map [list @type@ $type] { +# upvar #0 wbpbenum_@type@_number ary +# if {[catch {set ary($key)} num]} { +# return -code error "unknown @type@ '$key'" +# } +# return $num +# }] +# +# proc ::number_to_${type} {number} [string map [list @type@ $type] { +# upvar #0 wbpbenum_number_@type@ ary +# if {[catch {set ary($number)} @type@]} { +# return -code error "no @type@ for '$number'" +# } +# return $@type@ +# }] +# +# #eval "namespace eval ::sysnexus {namespace export number_to_${type}; namespace export ${type}_to_number}" +# #eval "namespace eval :: {namespace import -force sysnexus::number_to_${type} sysnexus::${type}_to_number}" +#} +# +#-------------------------------------------------------- +::>pattern .. Create >nest +>nest .. PatternVariable THIS +>nest .. PatternProperty data -autoclone +>nest .. Constructor {args} { + var o_data + var THIS + set THIS @this@ + array set o_data [list] +} +>nest .. PatternMethod item {args} { + set THIS @this@ + return [$THIS . data [join $args ,]] +} + +# +# e.g +# set [>nest a , b . data c .] blah +# >nest a , b , c +# +# set [>nest w x , y . data z .] etc +# >nest w x , y , z +#-------------------------------------------------------- + +} + +} + + +#package require patternlibtemp diff --git a/src/bootsupport/modules/patternpredator2-1.2.8.tm b/src/bootsupport/modules/patternpredator2-1.2.8.tm new file mode 100644 index 00000000..dd4f84c9 --- /dev/null +++ b/src/bootsupport/modules/patternpredator2-1.2.8.tm @@ -0,0 +1,755 @@ + +proc ::p::internals::jaws {OID _ID_ args} { + #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" + #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + yield + set w 1 + + set stack [list] + set wordcount [llength $args] + set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first + set unsupported 0 + set operator "" + set operator_prev "" ;#used only by argprotect to revert to previous operator + + + if {$OID ne "null"} { + #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) + #upvar #0 ::p::${OID}::_meta::map MAP + set MAP [set ::p::${OID}::_meta::map] + } else { + # error "jaws - OID = 'null' ???" + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key + } + set invocantdata [dict get $MAP invocantdata] + lassign $invocantdata OID alias default_method object_command wrapped + + set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code + + #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w + while {$w < $wordcount} { + set word [lindex $args [expr {$w -1}]] + #puts stdout "w:$w word:$word stack:$stack" + + if {$operator eq "argprotect"} { + set operator $operator_prev + lappend stack $word + incr w + } else { + if {[llength $stack]} { + if {$word in $terminals} { + set reduction [list 0 $_ID_ {*}$stack ] + #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" + + + set _ID_ [yield $reduction] + set stack [list] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] + #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" + } + + #review - 2018. switched to _ID_ instead of MAP + lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command + #lassign [dict get $MAP invocantdata] OID alias default_method object_command + + + #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" + set operator $word + #don't incr w + #incr w + } else { + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + lappend stack $word + } else { + #only look for leading argprotect chacter (-) if we're not already in argprotect mode + if {$word eq "--"} { + set operator_prev $operator + set operator "argprotect" + #Don't add the plain argprotector to the stack + } elseif {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + } + + + incr w + } + } else { + #no stack + switch -- $word {.} { + + if {$OID ne "null"} { + #we know next word is a property or method of a pattern object + incr w + set nextword [lindex $args [expr {$w - 1}]] + set command ::p::${OID}::$nextword + set stack [list $command] ;#2018 j + set operator . + if {$w eq $wordcount} { + set finished_args 1 + } + } else { + # don't incr w + #set nextword [lindex $args [expr {$w - 1}]] + set command $object_command ;#taken from the MAP + set stack [list "_exec_" $command] + set operator . + } + + + } {..} { + incr w + set nextword [lindex $args [expr {$w -1}]] + set command ::p::-1::$nextword + #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. + set stack [list $command] ;#faster, and intent is clearer than lappend. + set operator .. + if {$w eq $wordcount} { + set finished_args 1 + } + } {,} { + #puts stdout "Stackless comma!" + + + if {$OID ne "null"} { + set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + #object_command in this instance presumably be a list and $default_method a list operation + #e.g "lindex {A B C}" + } + #lappend stack $command + set stack [list $command] + set operator , + } {--} { + set operator_prev $operator + set operator argprotect + #no stack - + } {!} { + set command $object_command + set stack [list "_exec_" $object_command] + #puts stdout "!!!! !!!! $stack" + set operator ! + } default { + if {$operator eq ""} { + if {$OID ne "null"} { + set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + } + set stack [list $command] + set operator , + lappend stack $word + } else { + #no stack - so we don't expect to be in argprotect mode already. + if {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + + } + } + incr w + } + + } + } ;#end while + + #process final word outside of loop + #assert $w == $wordcount + #trailing operators or last argument + if {!$finished_args} { + set word [lindex $args [expr {$w -1}]] + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + + lappend stack $word + incr w + } else { + + + switch -- $word {.} { + if {![llength $stack]} { + #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] + yieldto return [::p::internals::ref_to_object $_ID_] + error "assert: never gets here" + + } else { + #puts stdout "==== $stack" + #assert - whenever _ID_ changed in this proc - we have updated the $OID variable + yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] + error "assert: never gets here" + } + set operator . + + } {..} { + #trailing .. after chained call e.g >x . item 0 .. + #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" + #set reduction [list 0 $_ID_ {*}$stack] + yieldto return [yield [list 0 $_ID_ {*}$stack]] + } {#} { + set unsupported 1 + } {,} { + set unsupported 1 + } {&} { + set unsupported 1 + } {@} { + set unsupported 1 + } {--} { + + #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] + #puts stdout " -> -> -> about to call yield $reduction <- <- <-" + set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] + } + yieldto return $MAP + } {!} { + #error "untested branch" + set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] + } + lassign [dict get $MAP invocantdata] OID alias default_command object_command + set command $object_command + set stack [list "_exec_" $command] + set operator ! + } default { + if {$operator eq ""} { + #error "untested branch" + lassign [dict get $MAP invocantdata] OID alias default_command object_command + #set command ::p::${OID}::item + set command ::p::${OID}::$default_command + lappend stack $command + set operator , + + } + #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. + lappend stack $word + } + if {$unsupported} { + set unsupported 0 + error "trailing '$word' not supported" + + } + + #if {$operator eq ","} { + # incr wordcount 2 + # set stack [linsert $stack end-1 . item] + #} + incr w + } + } + + + #final = 1 + #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" + + return [list 1 $_ID_ {*}$stack] +} + + + +#trailing. directly after object +proc ::p::internals::ref_to_object {_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 object_command + set refname ::p::${OID}::_ref::__OBJECT + + array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces + + set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" + trace add variable $refname {read} $traceCmd + } + set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] + if {[list {array} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {array} $traceCmd + } + + set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] + if {[list {write} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {write} $traceCmd + } + + set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] + if {[list {unset} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {unset} $traceCmd + } + return $refname +} + + +proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { + #if {[lindex $fullstack 0] eq "_exec_"} { + # #strip it. This instruction isn't relevant for a reference. + # set commandstack [lrange $fullstack 1 end] + #} else { + # set commandstack $fullstack + #} + #set argstack [lassign $commandstack command] + #set field [string map {> __OBJECT_} [namespace tail $command]] + + + + set reftail [namespace tail $refname] + set argstack [lassign [split $reftail +] field] + set field [string map {> __OBJECT_} [namespace tail $command]] + + #puts stderr "refname:'$refname' command: $command field:$field" + + + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + } else { + #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] + } + lassign [dict get $MAP invocantdata] OID alias default_method object_command + + + + if {$OID ne "null"} { + interp alias {} $refname {} $command $_ID_ {*}$argstack + } else { + interp alias {} $refname {} $command {*}$argstack + } + + + #set iflist [lindex $map 1 0] + set iflist [dict get $MAP interfaces level0] + #set iflist [dict get $MAP interfaces level0] + set field_is_property_like 0 + foreach IFID [lreverse $iflist] { + #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. + if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { + set field_is_property_like 1 + #There is a setter or getter (but not necessarily an entry in the o_properties dict) + break + } + } + + + + + #whether field is a property or a method - remove any commandrefMisuse_TraceHandler + foreach tinfo [trace info variable $refname] { + #puts "-->removing traces on $refname: $tinfo" + if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { + trace remove variable $refname {*}$tinfo + } + } + + if {$field_is_property_like} { + #property reference + + + set this_invocantdata [lindex [dict get $_ID_ i this] 0] + lassign $this_invocantdata OID _alias _defaultmethod object_command + #get fully qualified varspace + + # + set propdict [$object_command .. GetPropertyInfo $field] + if {[dict exists $propdict $field]} { + set field_is_a_property 1 + set propinfo [dict get $propdict $field] + set varspace [dict get $propinfo varspace] + if {$varspace eq ""} { + set full_varspace ::p::${OID} + } else { + if {[::string match "::*" $varspace]} { + set full_varspace $varspace + } else { + set full_varspace ::p::${OID}::$varspace + } + } + } else { + set field_is_a_property 0 + #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property + #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) + set full_varspace ::p::${OID} + } + + + + + + #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) + set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] + if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { + trace add variable ${full_varspace}::o_${field} {write} $Hndlr + } + set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] + if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { + trace add variable ${full_varspace}::o_${field} {unset} $Hndlr + } + + + #supply all data in easy-access form so that propref_trace_read is not doing any extra work. + set get_cmd ::p::${OID}::(GET)$field + set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] + + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + set fieldvarname ${full_varspace}::o_${field} + + + #synch the refvar with the real var if it exists + #catch {set $refname [$refname]} + if {[array exists $fieldvarname]} { + if {![llength $argstack]} { + #unindexed reference + array set $refname [array get $fieldvarname] + #upvar $fieldvarname $refname + } else { + set s0 [lindex $argstack 0] + #refs to nonexistant array members common? (catch vs 'info exists') + if {[info exists ${fieldvarname}($s0)]} { + set $refname [set ${fieldvarname}($s0)] + } + } + } else { + #refs to uninitialised props actually should be *very* common. + #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. + #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. + + #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! + + #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" + + + if {![llength $argstack]} { + #catch {set $refname [set ::p::${OID}::o_$field]} + if {[info exists $fieldvarname]} { + set $refname [set $fieldvarname] + #upvar $fieldvarname $refname + } + } else { + if {[llength $argstack] == 1} { + #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] + } + + } else { + #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] $argstack] + } + } + } + + #! what if someone has put a trace on ::errorInfo?? + #set ::errorInfo $errorInfo_prev + } + trace add variable $refname {read} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] + trace add variable $refname {write} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] + trace add variable $refname {unset} $traceCmd + + + set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] + # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" + trace add variable $refname {array} $traceCmd + } + + } else { + #puts "$refname ====> adding refMisuse_traceHandler $alias $field" + #matching variable in order to detect attempted use as property and throw error + + # 2018 + #Note that we are adding a trace on a variable (the refname) which does not exist. + #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) + #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added + ##array set $refname {} ;#empty array + # - the empty array would mean a slightly better error message when misusing a command ref as an array + #but this seems like a code complication for little benefit + #review + + trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] + } +} + + + +#trailing. after command/property +proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { + if {[lindex $fullstack 0] eq "_exec_"} { + #strip it. This instruction isn't relevant for a reference. + set commandstack [lrange $fullstack 1 end] + } else { + set commandstack $fullstack + } + set argstack [lassign $commandstack command] + set field [string map {> __OBJECT_} [namespace tail $command]] + + + #!todo? + # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. + # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. + + + #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. + # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. + + + set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] + + if {[llength [info commands $refname]]} { + #todo - review - what if the field changed to/from a property/method? + #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs + return $refname + } + ::p::internals::create_or_update_reference $OID $_ID_ $refname $command + return $refname +} + + +namespace eval pp { + variable operators [list .. . -- - & @ # , !] + variable operators_notin_args "" + foreach op $operators { + append operators_notin_args "({$op} ni \$args) && " + } + set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands + #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} +} +interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! + + + + + +# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. +#each map is a 2 element list of lists. +# form: {$commandinfo $interfaceinfo} +# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} + +#2018 +#each map is a dict. +#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} + + +#OID = Object ID (integer for now - could in future be a uuid) +proc ::p::predator2 {_ID_ args} { + #puts stderr "predator2: _ID_:'$_ID_' args:'$args'" + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + + #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. + #set this_role_members [dict get $invocants this] + #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. + #lassign $this_invocant this_OID this_info_dict + + set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + + set cheat 1 ;# + #------- + #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) + #(it should be functionally equivalent to remove this shortcut block) + if {$cheat} { + if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { + + set remaining_args [lassign $args dot method_or_prop] + + #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? + set command ::p::${this_OID}::$method_or_prop + #REVIEW! + #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') + #if {[llength $command] > 1} { + # error "methods with spaces not included in test suites - todo fix!" + #} + #Dont use {*}$command - (so we can support methods with spaces) + #if {![llength [info commands $command]]} {} + if {[namespace which $command] eq ""} { + if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { + #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces + set command ::p::${this_OID}::(UNKNOWN) + #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" + } + } else { + #tailcall {*}$command $_ID_ {*}$remaining_args + tailcall $command $_ID_ {*}$remaining_args + } + } + } + #------------ + + + if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { + return $_ID_ + } + + + #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" + + + + #puts stderr "this_info_dict: $this_info_dict" + + + + + if {![llength $args]} { + #should return some sort of public info.. i.e probably not the ID which is an implementation detail + #return cmd + return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID + + #return a dict keyed on object command name - (suitable as use for a .. Create 'target') + #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped + #return [list $object_command [list -id $this_OID ]] + } elseif {[llength $args] == 1} { + #short-circuit the single index case for speed. + if {[lindex $args 0] ni {.. . -- - & @ # , !}} { + #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method + lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method + + tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] + } elseif {[lindex $args 0] eq {--}} { + + #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. + # - combined with using UUIDs for $OID, and a secured/removed metaface on the object + # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) + # - this could effectively hide the object's namespaces,vars etc from the caller (?) + return [set ::p::${this_OID}::_meta::map] + } + } + + + + #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) + #incr c + #set reduce ::p::reducer${this_OID}_$c + set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] + #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" + coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args + + + set current_ID_ $_ID_ + + set final 0 + set result "" + while {$final == 0} { + #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) + set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] + #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" + #if {[string match *Destroy $command]} { + # puts stdout " calling Destroy reduction_args:'$reduction_args'" + #} + if {$final == 1} { + + if {[llength $command] == 1} { + if {$command eq "_exec_"} { + tailcall {*}$reduction_args + } + if {[llength [info commands $command]]} { + tailcall {*}$command $current_ID_ {*}$reduction_args + } + set cmdname [namespace tail $command] + set this_OID [lindex [dict get $current_ID_ i this] 0 0] + if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { + lset command 0 ::p::${this_OID}::(UNKNOWN) + tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" + } + + } else { + #e.g lindex {a b c} + tailcall {*}$command {*}$reduction_args + } + + + } else { + if {[lindex $command 0] eq "_exec_"} { + set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] + + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] + } else { + if {[llength $command] == 1} { + if {![llength [info commands $command]]} { + set cmdname [namespace tail $command] + set this_OID [lindex [dict get $current_ID_ i this] 0 0] + if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { + + lset command 0 ::p::${this_OID}::(UNKNOWN) + set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" + } + } else { + #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] + set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] + + } + } else { + set result [uplevel 1 [list {*}$command {*}$reduction_args]] + } + + if {[llength [info commands $result]]} { + if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { + #looks like a pattern command + set current_ID_ [$result .. INVOCANTDATA] + + + #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA + #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { + # set current_ID_ $result_invocantdata + #} else { + # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" + #} + } else { + #non-pattern command + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + } + } else { + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) + + } + } + + } + } + error "Assert: Shouldn't get here (end of ::p::predator2)" + #return $result +} + +package provide patternpredator2 1.2.8 diff --git a/src/bootsupport/modules/punk-0.1.tm b/src/bootsupport/modules/punk-0.1.tm index 55408253..90b3d334 100644 --- a/src/bootsupport/modules/punk-0.1.tm +++ b/src/bootsupport/modules/punk-0.1.tm @@ -8122,10 +8122,10 @@ namespace eval punk { interp alias {} mode {} punk::mode proc aliases {{glob *}} { - tailcall punk::lib::aliases $glob + tailcall punk::ns::aliases $glob } proc alias {{aliasorglob ""} args} { - tailcall punk::lib::alias $aliasorglob {*}$args + tailcall punk::ns::alias $aliasorglob {*}$args } diff --git a/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/bootsupport/modules/punk/aliascore-0.1.0.tm index b8fada0b..0ab37079 100644 --- a/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -108,8 +108,6 @@ tcl::namespace::eval punk::aliascore { # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. set aliases [tcl::dict::create\ val ::punk::pipe::val\ - aliases ::punk::lib::aliases\ - alias ::punk::lib::alias\ tstr ::punk::lib::tstr\ list_as_lines ::punk::lib::list_as_lines\ lines_as_list ::punk::lib::lines_as_list\ @@ -138,6 +136,8 @@ tcl::namespace::eval punk::aliascore { config ::punk::config\ s ::punk::ns::synopsis\ eg ::punk::ns::eg\ + aliases ::punk::ns::aliases\ + alias ::punk::ns::alias\ ] #*** !doctools diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index 15421402..64f3a0fd 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -147,14 +147,18 @@ tcl::namespace::eval punk::ansi::class { }] method render_to_input_line {args} { if {[llength $args] < 1} { - puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args + #puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" + #punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line" + return } set x [lindex $args end] set arglist [lrange $args 0 end-1] if {[llength $arglist] %2 != 0} { - puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args + #puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" + #punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line" + return } set opts [tcl::dict::create\ -dimensions 80x24\ @@ -6076,12 +6080,13 @@ tcl::namespace::eval punk::ansi::ta { } #perl: ta_strip + punk::args::set_alias ::punk::ansi::ta::strip ::punk::ansi::ansistrip proc strip {text} { #*** !doctools #[call [fun strip] [arg text]] #[para]Return text stripped of Ansi codes #[para]This is a tailcall to punk::ansi::ansistrip - tailcall ansistrip $text + tailcall punk::ansi::ansistrip $text } lappend PUNKARGS [list { @@ -6113,7 +6118,7 @@ tcl::namespace::eval punk::ansi::ta { "Calculate length of text (excluding the ANSI codes) This is not the printing length of the string on screen." @values -min 1 - text -type string + text -type string } ] #perl: ta_length proc length {text} { @@ -6133,7 +6138,7 @@ tcl::namespace::eval punk::ansi::ta { #perl: ta_trunc #truncate $text to $width columns while still including all the ANSI colour codes. proc trunc {text width args} { - + error "unimplemented" } #not in perl ta diff --git a/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm b/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm index 6e8e28e4..3f914682 100644 --- a/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm +++ b/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- # Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_::punk::ansi::colourmap 0 0.1.0] +#[manpage_begin punkshell_module_::punk::ansi::colourmap 0 0.1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/bootsupport/modules/punk/args-0.2.tm b/src/bootsupport/modules/punk/args-0.2.tm index ef4765e1..47338954 100644 --- a/src/bootsupport/modules/punk/args-0.2.tm +++ b/src/bootsupport/modules/punk/args-0.2.tm @@ -257,7 +257,7 @@ tcl::namespace::eval punk::args::register { if {![info exists scanned_info]} { set scanned_info [dict create] } - #some packages, e.g punk::args::tclcore document other namespaces. + #some packages, e.g punk::args::moduledoc::tclcore document other namespaces. #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources variable namespace_docpackages if {![info exists namespace_docpackages]} { @@ -466,6 +466,8 @@ tcl::namespace::eval punk::args { recognised types: any (unvalidated - accepts anything) + unknown + (unvalidated - accepts anything) none (used for flags/switches only. Indicates this is a 'solo' flag ie accepts no value) @@ -475,6 +477,8 @@ tcl::namespace::eval punk::args { number list indexexpression + indexset + (as accepted by punk::lib::is_indexset) dict double float @@ -632,7 +636,7 @@ tcl::namespace::eval punk::args { from existing definitions (by id) for re-use of argument specifications and help text) e.g the following definition passes 2 blocks as text arguments - ${[punk::args::tclcore::argdoc::example { + ${[punk::args::moduledoc::tclcore::argdoc::example { punk::args::define { @id -id ::myns::myfunc @cmd -name myns::myfunc -help\ @@ -764,24 +768,25 @@ tcl::namespace::eval punk::args { if {[dict exists $rawdef_cache $args]} { return [dict get [dict get $rawdef_cache $args] -id] } else { - set id [rawdef_id $args] + set lvl 2 + set id [rawdef_id $args $lvl] if {[id_exists $id]} { #we seem to be re-creating a previously defined id... #clear any existing caches for this id - puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + undefine $id 0 - #dict unset argdata_cache $prevraw ;#silently does nothing if key not present - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k - } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k - } - } - dict unset id_cache_rawdef $id + ##dict unset argdata_cache $prevraw ;#silently does nothing if key not present + #dict for {k v} $argdata_cache { + # if {[dict get $v id] eq $id} { + # dict unset argdata_cache $k + # } + #} + #dict for {k v} $rawdef_cache { + # if {[dict get $v -id] eq $id} { + # dict unset rawdef_cache $k + # } + #} + #dict unset id_cache_rawdef $id } set is_dynamic [rawdef_is_dynamic $args] set defspace [uplevel 1 {::namespace current}] @@ -790,6 +795,35 @@ tcl::namespace::eval punk::args { return $id } } + proc undefine {id {quiet 0}} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[id_exists $id]} { + if {!$quiet} { + puts stderr "punk::args::undefine clearing existing data for id:$id" + } + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } else { + if {!$quiet} { + puts stderr "punk::args::undefine unable to find id: '$id'" + } + } + } + #'punk::args::parse $args withdef $deflist' can raise parsing error after an autoid was generated + # In this case we don't see the autoid in order to delete it + #proc undefine_deflist {deflist} { + #} proc idquery_info {id} { variable id_cache_rawdef @@ -889,7 +923,8 @@ tcl::namespace::eval punk::args { set textargs $args if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} + #punk::args::get_by_id ::punk::args::define {} + punk::args::parse {} -errorstyle minimal withid ::punk::args::define return } #if {[lindex $args 0] eq "-dynamic"} { @@ -1184,7 +1219,7 @@ tcl::namespace::eval punk::args { } ref { #a reference within the definition - #e.g see punk::args::tclcore ::after + #e.g see punk::args::moduledoc::tclcore ::after #global reference dict - independent of forms #ignore refs without an -id #store all keys except -id @@ -1952,6 +1987,7 @@ tcl::namespace::eval punk::args { char - character {set normtype char} dict - dictionary {set normtype dict} index - indexexpression {set normtype indexexpression} + indexset {set normtype indexset} "" - none - solo { if {$is_opt} { #review - are we allowing clauses for flags? @@ -1975,6 +2011,10 @@ tcl::namespace::eval punk::args { } } any - anything {set normtype any} + unknown { + #'unspecified' ?? + set normtype unknown + } ansi - ansistring {set normtype ansistring} string - globstring {set normtype $lc_firstword} literal { @@ -2705,25 +2745,38 @@ tcl::namespace::eval punk::args { #@dynamic only has meaning as 1st element of a def in the deflist } - #@id must be within first 4 lines of a block - or assign auto + #@id must be within first 4 lines of first 3 blocks - or assign auto #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { + proc rawdef_id {rawdef {lvl 1}} { set id "" - foreach d $rawdef { + set found_id_line 0 + foreach d [lrange $rawdef 0 2] { foreach ln [lrange [split $d \n] 0 4] { if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { if {$firstword eq "@id"} { + set found_id_line 1 + #review - uplevel 2 would be a call from punk::args::define ?? + set rest [uplevel $lvl [list punk::args::lib::tstr -allowcommands $rest]] if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { set id [dict get $rest -id] - break } + break } } } - if {$id ne ""} { + if {$found_id_line} { break } } + if {$id eq "" && $found_id_line} { + #Looked like an @id - but presumable the rest of the line was malformed. + #we won't produce an autoid for such a definition. + set first3blocks "" + foreach b [lrange $rawdef 0 2] { + append first3blocks $b\n + } + error "punk::args::rawdef_id found an @id line in the first 4 lines of one of the 1st 3 blocks - but failed to retrieve a value for it.\nraw_def 1st 3 blocks:\n$first3blocks" + } if {$id eq "" || [string tolower $id] eq "auto"} { variable id_counter set id "autoid_[incr id_counter]" @@ -2916,7 +2969,9 @@ tcl::namespace::eval punk::args { set seen_documentedns [list] ;#seen per pkgns foreach definitionlist [set ${pkgns}::PUNKARGS] { #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] + #set id [rawdef_id $definitionlist] + set lvl 1 ;#level at which tstr substitution occurs in @id line + set id [namespace eval $pkgns [list punk::args::rawdef_id $definitionlist $lvl]] if {[string match autoid_* $id]} { puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" puts stderr "definition:\n" @@ -2958,6 +3013,9 @@ tcl::namespace::eval punk::args { } else { set needed [list] foreach pkgns $nslist { + if {[string match (autodef)* $pkgns]} { + set pkgns [string range $pkgns 9 end] + } if {![string match ::* $pkgns]} { puts stderr "warning: update_definitions received unqualified ns: $pkgns" set pkgns ::$pkgns @@ -3443,18 +3501,28 @@ tcl::namespace::eval punk::args { set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] set docurl [Dict_getdef $spec_dict doc_info -url ""] - #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - #if {"$argdisplay_header$argdisplay_body" eq ""} { - # set is_custom_argdisplay 0 - #} else { - # set is_custom_argdisplay 1 - #} - - #temp - TODO + #review - when can there be more than one selected form? set argdisplay_header "" set argdisplay_body "" - set is_custom_argdisplay 0 + if {[llength $selected_forms] == 1} { + set fid [lindex $selected_forms 0] + set FRM [dict get $spec_dict FORMS $fid] + if {[dict size [dict get $FRM FORMDISPLAY]]} { + set argdisplay_header [Dict_getdef $FRM FORMDISPLAY -header ""] + set argdisplay_body [Dict_getdef $FRM FORMDISPLAY -body ""] + } + } + + + # if {![dict size $F $fid $FORMDISPLAY]} {} + #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + if {"$argdisplay_header$argdisplay_body" eq ""} { + set is_custom_argdisplay 0 + } else { + set is_custom_argdisplay 1 + } + #set is_custom_argdisplay 0 set blank_header_col [list] @@ -4335,7 +4403,7 @@ tcl::namespace::eval punk::args { documentation generated dynamically and may not yet have an id. IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - Generally punk::ns::arginfo (aliased as i in the punk shell) should + Generally punk::ns::cmdhelp (aliased as i in the punk shell) should be used in preference - as it will search for a documentation mechanism and call punk::args::usage as necessary. " @@ -5730,6 +5798,15 @@ tcl::namespace::eval punk::args { break } } + indexset { + if {![punk::lib::is_indexset $e_check]} { + set msg "$argclass $argname for %caller% requires type indexset. A comma-delimited set of indexes or index-ranges separated by '..' Received: '$e_check'" + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + } else { + lset clause_results $c_idx $a_idx 1 + break + } + } string - ansistring - globstring { #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string #we possibly don't want to always have to regex on things that don't pass the other more basic checks @@ -8729,7 +8806,7 @@ tcl::namespace::eval punk::args { } set type_expression [string trim $typespec ?] - if {$type_expression in {any none}} { + if {$type_expression in {any none unknown}} { continue } #puts "$argname - switch on type_expression: $type_expression v:[lindex $vlist $clausecolumn]" @@ -8790,7 +8867,8 @@ tcl::namespace::eval punk::args { dict set finalopts $o $v } } - return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + set docid [dict get $argspecs id] + return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived id $docid] } lappend PUNKARGS [list { @@ -9570,8 +9648,15 @@ tcl::namespace::eval punk::args { } } - set cinfo [punk::ns::resolve_command {*}$cmd] - set tp [dict get $cinfo cmdtype] + #don't use full cmdinfo if $cmd is a single element + if {[llength $cmd] == 1} { + set cinfo [punk::ns::cmdwhich $cmd] + set tp [dict get $cinfo whichtype] + } else { + puts stderr "WARNING ==ensemble_subcommands_definition== cmdinfo $cmd\n$cinfo" + set cinfo [punk::ns::cmdinfo {*}$cmd] + set tp [dict get $cinfo cmdtype] + } dict set choiceinfodict $sc [list [list resolved $cmd]] @@ -9584,9 +9669,23 @@ tcl::namespace::eval punk::args { } } - if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} { + #could be more than one punk::args id - choose a precedence by how we order the id_exists checks. + if {[punk::args::id_exists [list $ensemble $sc]]} { + dict lappend choiceinfodict $sc {doctype punkargs} + dict lappend choiceinfodict $sc [list subhelp {*}$ensemble $sc] + } elseif {[punk::args::id_exists $cmd]} { dict lappend choiceinfodict $sc {doctype punkargs} + dict lappend choiceinfodict $sc [list subhelp {*}$cmd] + } elseif {[punk::args::id_exists [dict get $cinfo origin]]} { + dict lappend choiceinfodict $sc {doctype punkargs} + dict lappend choiceinfodict $sc [list subhelp {*}[dict get $cinfo origin]] + } else { + #puts stderr "ensemble_subcommands_definition--- NO doc for [list $ensemble $sc] or $cmd or [dict get $cinfo origin]" } + + #if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} { + # dict lappend choiceinfodict $sc {doctype punkargs} + #} } set argdef "" @@ -9699,9 +9798,18 @@ tcl::namespace::eval punk::args::lib { ooc { lappend marks [punk::ns::Cmark ooc cyan] } + classmethod { + lappend marks [punk::ns::Cmark classmethod term-orange1] + } + coremethod { + lappend marks [punk::ns::Cmark coremethod term-plum1] + } ooo { lappend marks [punk::ns::Cmark ooo cyan] } + objectmethod { + lappend marks [punk::ns::Cmark objectmethod term-orange1] + } native { lappend marks [punk::ns::Cmark native] } @@ -9724,11 +9832,11 @@ tcl::namespace::eval punk::args::lib { @id -id ::punk::args::lib::tstr @cmd -name punk::args::lib::tstr\ -summary\ - "Templating with \$\{$varName\}"\ + "Templating with placeholders such as: \$\{$varName\}"\ -help\ - "A rough equivalent of js template literals + "Roughly analogous to js template literals - Substitutions: + Placeholder Substitutions: \$\{$varName\} \$\{[myCommand]\} (when -allowcommands flag is given)" diff --git a/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm b/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm new file mode 100644 index 00000000..10413ffc --- /dev/null +++ b/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm @@ -0,0 +1,7031 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::args::moduledoc::tclcore 0.1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 0.1.0] +#[copyright "2025"] +#[titledesc {punk::args definitions for tcl core commands}] [comment {-- Name section and table of contents description --}] +#[moddesc {tcl core argument definitions}] [comment {-- Description at end of page heading --}] +#[require punk::args::moduledoc::tclcore] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::args::moduledoc::tclcore +#[subsection Concepts] +#[para] This is a punk::args module documentation package. +#[para] It provides punk::args definitions for core Tcl commands, + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args::moduledoc::tclcore +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +package require punk::ansi +package require textblock +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::args}] +#[item] [package {punk::ansi}] +#[item] [package {textblock}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::moduledoc::tclcore { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + + #for tcllib - we can potentially parse the doctools to get this info. + #for tcl core commands - the data is stored in man pages - which are not so easy to parse. + #todo - link to man pages + + + #TODO - + #if we want colour in arg definitions -we need to respect nocolor or change colour to off/ on + #If color included in a definition - it will need to be reloaded when colour toggled(?) + #if {[catch {package require punk::ansi}]} { + # set has_punkansi 0 + # set A_WARN "" + # set A_RST "" + #} else { + # set has_punkansi 1 + # set A_WARN [a+ red] + # set A_RST "\x1b\[0m" + #} + + #we can't just strip ansi as there are non colour codes such as hyperlink that should be maintained whether color is on or off. + #for now we can use reverse - (like underline, is a non-colour attribute that remains effective when color off in punk::ansi) + set A_WARN \x1b\[7m + set A_RST \x1b\[0m + + variable manbase_tcl + variable manbase_ext + set patch [info patchlevel] + lassign [split $patch .] major + if {$major < 9} { + set manbase_tcl "https://tcl.tk/man/tcl/TclCmd" + set manbase_ext .htm + } else { + set manbase_tcl "https://tcl.tk/man/tcl9.0/TclCmd" + set manbase_ext .html + } + proc manpage_tcl {cmd} { + variable manbase_tcl + variable manbase_ext + return ${manbase_tcl}/${cmd}${manbase_ext} + } + + variable PUNKARGS + + namespace eval argdoc { + tcl::namespace::import ::punk::ansi::a+ + tcl::namespace::import ::punk::args::moduledoc::tclcore::manpage_tcl + # -- --- --- --- --- + #non colour SGR codes + # we can use these directly via ${$I} etc without marking a definition with @dynamic + #This is because they don't need to change when colour switched on and off. + set I [a+ italic] + set NI [a+ noitalic] + set B [a+ bold] + set N [a+ normal] + # -- --- --- --- --- + proc example {str} { + set str [string trimleft $str \n] + set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Web-gray bold white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]] + set result [textblock::bookend_lines $block [a] "[a defaultbg] [a]"] + #puts $result + return $result + } + } + + + namespace eval argdoc { + #*** !doctools + #[subsection {Namespace punk::args::moduledoc::tclcore::argdoc}] + #[para] This is the main documentation namespace where calls to punk::args::define are made, and definitions are added to the punk::args::moduledoc::tclcore::argdoc::PUNKARGS variable. + #[para] Some utility functions exist here for use in the definitions. + #[list_begin definitions] + + variable PUNKARGS + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::moduledoc::tclcore::argdoc ---}] + } + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + # + # library commands loaded via auto_index + # + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::parray + @cmd -name "Built-in: parray" -help\ + "Prints on standard output the names and values of all the elements in the + array arrayName, or just the names that match pattern (using the matching + rules of string_match) and their values if pattern is given. + ArrayName must be an array accessible to the caller of parray. It may either + be local or global. The result of this command is the empty string. + (loaded via auto_index)" + @values -min 1 -max 2 + arrayName -type string -help\ + "variable name of an array" + pattern -type string -optional 1 -help\ + "Match pattern possibly containing glob characters" + } "@doc -name Manpage: -url [manpage_tcl library]" ] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::foreachLine + @cmd -name "Built-in: foreachLine" -help\ + "This reads in the text file named ${$I}filename${$NI} one line at a time (using system + defaults for reading text files). It writes that line to the variable named + by ${$I}varName${$NI} and then executes ${$I}body${$NI} for that line. The result value of ${$I}body${$NI} is + ignored, but error, return, break and continue may be used within it to + produce an error, return from the calling context, stop the loop, or go to + the next line respectively. The overall result of ${$B}foreachLine${$N} is the empty + string (assuming no errors from I/O or from evaluating the body of the loop); + the file will be closed prior to the procedure returning." + @values -min 3 -max 3 + varName + fileName + body + } "@doc -name Manpage: -url [manpage_tcl library]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::readFile + @cmd -name "Built-in: readFile" -help\ + "Reads in the file named in ${$I}filename${$NI} and returns its contents. The second + argument says how to read in the file, either as ${$B}text${$N} (using the system + defaults for reading text files) or as ${$B}binary${$N} (as uninterpreted bytes). + The default is ${$B}text${$N}. When read as text, this will include any trailing + newline. The file will be closed prior to the procedure returning." + @values -min 1 -max 2 + fileName + #todo punk::args::synopsis - show prefix highlighting + mode -type literalprefix(text)|literalprefix(binary) -optional 1 + #test + #mode -type {{literalprefix text | literalprefix binary}} + } "@doc -name Manpage: -url [manpage_tcl library]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::writeFile + @cmd -name "Built-in: writeFile" -help\ + "Writes the contents to the file named in ${$I}filename${$NI}. The optional second + argument says how to write to the file, either as ${$B}text${$N} (using the system + defaults for writing text files) or as ${$B}binary${$N} (as uninterpreted bytes). + The default is ${$B}text${$N}. If a trailing newline is required, it will need to + be provided in ${$I}contents${$NI}. The result of this command is the empty string; + the file will be closed prior to the procedure returning." + @values -min 2 -max 3 + fileName + mode -type literalprefix(text)|literalprefix(binary) -optional 1 + contents + } "@doc -name Manpage: -url [manpage_tcl library]" ] + + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + # (end of auto_index commands) + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + namespace eval argdoc { + punk::args::define { + @id -id ::tcl::info::args + @cmd -name "Built-in: tcl::info::args" -help\ + "Returns the names of the parameters to the procedure named ${$I}procname${$NI}." + @values -min 1 -max 1 + procname -type string -optional 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::body + @cmd -name "Built-in: tcl::info::body" -help\ + "Returns the body procedure named ${$I}procname${$NI}." + @values -min 1 -max 1 + procname -type string -optional 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::cmdcount + @cmd -name "Built-in: tcl::info::cmdcount" -help\ + "Returns the total number of commands evaluated in this interpreter." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::cmdtype + @cmd -name "Built-in: tcl::info::cmdtype" -help\ + "Returns the type of the command named ${$I}commandName${$NI}. + Built-in types are: + ${$B}alias${$N} + ${$I}commandName${$NI} was created by 'interp alias'. In a safe interpreter an + alias is only visible if both the alias and the target are visible. + ${$B}coroutine${$N} + ${$I}commandName${$NI} was created by 'coroutine'. + ${$B}ensemble${$N} + ${$I}commandName${$NI} was created by 'namespace ensemble'. + ${$B}import${$N} + ${$I}commandName${$NI} was created by 'namespace import'. + ${$B}native${$N} + ${$I}commandName${$NI} was created by the 'Tcl_CreateObjCommand' interface + directly without further registration of the type of command. + ${$B}object${$N} + ${$I}commandName${$NI} is the public comand that represents an instance + of oo::object or one of its subclasses. + ${$B}privateObject${$N} + ${$I}commandName${$NI} is the private command, my by default, + that represents an instance of oo::object or one of its subclasses. + ${$B}proc${$N} + ${$I}commandName${$NI} was created by 'proc'. + ${$B}interp${$N} + ${$I}commandName${$NI} was created by 'interp create'. + ${$B}zlibStream${$N} + ${$I}commandName${$NI} was created by 'zlib stream'. + " + @values -min 1 -max 1 + commandName -type string + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::coroutine + @cmd -name "Built-in: tcl::info::coroutine" -help\ + "Returns the name of the current ${$B}coroutine${$N}, or the empty string if there + is no current coroutine or the current coroutine has been deleted." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::default + @cmd -name "Built-in: tcl::info::default" -help\ + "If the parameter ${$I}parameter${$NI} for the procedure named ${$I}procname${$NI} + has a default value, stores that value in ${$I}varname${$NI} and returns ${$B}1${$N}. + Otherwise, returns ${$B}0${$N}." + @values -min 3 -max 3 + procname -type string -optional 0 + parameter + varname + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::functions + @cmd -name "Built-in: tcl::info::functions" -help\ + "If ${$I}pattern${$NI} is not given, returns a list of all the math functions currently defined. + If ${$I}pattern${$NI} is given, returns only those names that match ${$I}pattern${$NI} according to ${$B}string match${$N}." + @values -min 0 -max 2 + pattern -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::globals + @cmd -name "Built-in: tcl::info::globals" -help\ + "If ${$I}pattern${$NI} is not given, returns a list of all the names of currently-defined + global variables. Global variables are variables in the global namespace. If ${$I}pattern${$NI} is + given, only those names matching ${$I}pattern${$NI} are returned. Matching is determined using the + same rules as for ${$B}string match${$N}." + @values -min 0 -max 2 + pattern -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::hostname + @cmd -name "Built-in: tcl::info::hostname" -help\ + "Returns the name of the current host. + This name is not guaranteed to be the fully-qualified domain name of the host. + Where machines have several different names, as is common on systems with + both TCP/IP (DNS) and NetBIOS-based networking installed, it is the name that + is suitable for TCP/IP networking that is returned." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::level + @cmd -name "Built-in: tcl::info::level" -help\ + "If number is not given, the level this routine was called from. Otherwise + returns the complete command active at the given level. If number is greater + than ${$B}0${$N}, it is the desired level. Otherwise, it is number levels up from the + current level. A complete command is the words in the command, with all + substitutions performed, meaning that it is a list. See ${$B}uplevel${$N} for more + information on levels." + @values -min 0 -max 2 + level -type integer -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::library + @cmd -name "Built-in: tcl::info::library" -help\ + "Returns the value of ${$B}tcl_library${$N}, which is the name of the library + directory in which the scripts distributed with Tcl scripts are stored." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::loaded + @cmd -name "Built-in: tcl::info::loaded" -help\ + "Returns the name of each file loaded in interp by the load command with + prefix prefix . If prefix is not given, returns a list where each item is + the name of the loaded file and the prefix for which the file was loaded. + For a statically-loaded package the name of the file is the empty string. + For interp, the empty string is the current interpreter." + @values -min 0 -max 2 + interp -type string -optional 1 + prefix -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::locals + @cmd -name "Built-in: tcl::info::locals" -help\ + "If ${$I}pattern${$NI} is given, returns the name of each local variable matching + pattern according to ${$B}string match${$N}. Otherwise, returns the name of each local + variable. A variables defined with the ${$B}global${$N}, ${$B}upvar${$N} or ${$B}variable${$N} is not local." + @values -min 0 -max 2 + pattern -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + + punk::args::define { + @id -id ::tcl::info::nameofexecutable + @cmd -name "Built-in: tcl::info::nameofexecutable" -help\ + "Returns the absolute pathname of the program for the current interpreter. + If such a file can not be identified an empty string is returned." + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" + + + punk::args::define { + @id -id ::oo::InfoObject::call + @cmd -name "Built-in: oo::InfoObject::call" -help\ + "Returns a description of the method implementations that are used to provide + ${$I}object's${$NI} implementation of ${$I}method${$NI}. This consists of a + list of lists of four elements, where each sublist consists of: + element 0: a word that describes the general type of method implementation, being + one of + ${$B}method${$N} for an ordinary method, ${$B}filter${$N} for an applied filter, + ${$B}private${$N} for a private method, and ${$B}unknown${$N} for a method that + is invoked as part of unknown method handling. + element 1: a word giving the name of the particular method invoked (which is always + the same as method for the ${$B}method${$N} type, and \"${$B}unknown${$N}\" + for the ${$B}unknown${$N} type) + element 2: a word giving what defined the method (the fully qualified name of the + class, or the literal string ${$B}object${$N} if the method implementation is on + an instance) + element 3: a word describing the type of method implementation + (see ${$B}info object methodtype${$N}) + + Note that there is no inspection of whether the method implementations actually use + ${$B}next${$N} to transfer control along the call chain, and the call chains that + this command files do not actually contain private methods." + @values -min 2 -max 2 + object + method + } "@doc -name Manpage: -url [manpage_tcl info]" + + + #--------- + punk::args::define { + @id -id ::oo::InfoClass::call + @cmd -name "Built-in: oo::InfoClass::call" -help\ + "Returns a description of the method implementations that are used to provide + a stereotypical instance of ${$I}class's${$NI} implementation of ${$I}method${$NI}. + (stereotypical instances being objects instantiated by a class without having any + object-specific definitions added). + This consists of a + list of lists of four elements, where each sublist consists of: + element 0: a word that describes the general type of method implementation, being + one of + ${$B}method${$N} for an ordinary method, ${$B}filter${$N} for an applied filter, + ${$B}filter${$N} for an applied filter, + ${$B}private${$N} for a private method, and ${$B}unknown${$N} for a method that + is invoked as part of unknown method handling. + element 1: a word giving the name of the particular method invoked (which is always + the same as method for the ${$B}method${$N} type, and \"${$B}unknown${$N}\" + for the ${$B}unknown${$N} type) + element 2: a word giving the fully qualified name of the class that defined the + method + element 3: a word describing the type of method implementation + (see ${$B}info class methodtype${$N}) + + Note that there is no inspection of whether the method implementations actually use + ${$B}next${$N} to transfer control along the call chain, and the call chains that + this command files do not actually contain private methods." + @values -min 2 -max 2 + class + method + } "@doc -name Manpage: -url [manpage_tcl info]" + + proc info_subcommands {} { + #package require punk::ns + #set subdict [punk::ns::ensemble_subcommands -return dict info] + #set allsubs [dict keys $subdict] + dict set groups "system" {hostname library nameofexecutable patchlevel script sharedlibextension tclversion} + dict set groups "proc introspection" {args body default} + dict set groups "variables" {constant consts exists globals locals vars} + dict set groups "oo object introspection" {class object} + + return [punk::args::ensemble_subcommands_definition -groupdict $groups -columns 4 info] + } + set DYN_INFO_SUBCOMMANDS {${[punk::args::moduledoc::tclcore::argdoc::info_subcommands]}} + lappend PUNKARGS [list { + @dynamic + @id -id ::info + @cmd -name "Built-in: info"\ + -summary\ + "Information about the state of the Tcl interpreter"\ + -help\ + "Information about the state of the Tcl interpreter" + @leaders -min 1 -max 1 + ${$DYN_INFO_SUBCOMMANDS} + @values -min 0 + + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl array]" ] + } + + + + #An idiom for sharing common features - incomplete - todo work out what happens with (default)::id that has leaders,opts,values + #todo @cmd -help+ text (append to existing help that came from a default?) + lappend PUNKARGS [list { + @id -id "(default)::tcl::binary::*::base64" + @cmd -help\ + "The base64 binary encoding is commonly used in mail messages and XML documents, + and uses mostly upper and lower case letters and digits. It has the distinction + of being able to be rewrapped arbitrarily without losing information. + " + } "@doc -name Manpage: -url [manpage_tcl binary]" ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::encode::base64" + @default -id (default)::tcl::binary::*::base64 + @cmd -name "binary encode base64" + -maxlen -type integer -help\ + "Indicates that the output should be split into lines of no more than length + characters. By default, lines are not split." + -wrapchar -type character -default \n -help\ + "Indicates that, when lines are split because of the -maxlen option, character + should be used to separate lines. By default, this is a newline character, \"\\n\"." + @values -min 1 -max 1 + data -type string + } ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::decode::base64" + @default -id (default)::tcl::binary::*::base64 + @cmd -name "binary decode base64" + -strict -type none -help\ + "Instructs the decoder to throw an error if it encounters any characters that + are not strictly part of the encoding itself. Otherwise it ignores them. + RFC 2045 calls for base64 decoders to be non-strict." + @values -min 1 -max 1 + data -type string + } ] + + + lappend PUNKARGS [list { + @id -id "(default)::tcl::binary::*::hex" + @cmd -help\ + "The hex binary encoding converts each byte to a pair of hexadecimal digits + that represent the byte value as a hexadecimal integer. When encoding, lower + characters are used. When decoding, upper and lower characters are accepted." + } "@doc -name Manpage: -url [manpage_tcl binary]" ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::encode::hex" + @default -id (default)::tcl::binary::*::hex + @cmd -name "binary encode hex"\ + -summary "Encode each byte to a pair of hex digits (lower case output)" + @values -min 1 -max 1 + data -type string + } ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::decode::hex" + @default -id (default)::tcl::binary::*::hex + @cmd -name "binary encode hex"\ + -summary "Decode contiguous pairs of hex digits to bytes (input may be upper or lower case)" + -strict -type none -help\ + "Instructs the decoder to throw an error if it encounters whitespace + characters. Otherwise it ignores them. + Whether -strict is applied or not, a trailing unpaired hex digit is ignored." + @values -min 1 -max 1 + data -type string + }] + + + lappend PUNKARGS [list { + @id -id "(default)::tcl::binary::*::uuencode" + @cmd -help\ + "The uuencode binary encoding used to be common for transfer of data between Unix + systems and on USENT, but is less common these days, having been largely + superseded by the base64 binary encoding. + Note that neither the encoder nor the decoder handle the header and footer of the + uuencode format." + } "@doc -name Manpage: -url [manpage_tcl binary]" ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::encode::uuencode" + @default -id (default)::tcl::binary::*::uuencode + #todo @cmd -help+ "Changing the options may produce files that other implementations of decoders cannot process" + @cmd -name "binary encode uuencode" + -maxlen -type integer -default 61 -range {5 85} -help\ + "Indicates the maximum number of characters to produce for each encoded line. + The valid range is 5 to 85. Line lengths outside that range cannot be + accommodated by the encoding format." + -wrapchar -type string -default \n -help\ + "Indicates the character(s) to use to mark the end of each encoded line. + Acceptable values are a sequence of zero or more character from the set + { \\x09 (TAB), \\x0B (VT), \\x0C (FF), \\x0D (CR) } followed by zero or + one newline \\x0A (LF). Any other values are rejected because they would + generate encoded text that could not be decoded. The default value is a + single newline. + " + @values -min 1 -max 1 + data -type string + } ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::decode::uuencode" + @default -id (default)::tcl::binary::*::uuencode + @cmd -name "binary decode uuencode" + -strict -type none -help\ + "Instructs the decoder to throw an error if it encounters anything outside + of the standard encoding format. Without this option, the decoder tolerates + some deviations, mostly to forgive reflows of lines between the encoder and + decoder." + @values -min 1 -max 1 + data -type string + } ] + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::convertfrom" + @cmd -name "encoding convertfrom" -help\ + "Converts data, which should be in the form of a binary string encoded as per encoding, + to a Tcl string. If encoding is not specified, the current system encoding is used." + + @form -form basic + @values -min 1 -max 2 + encoding -type string -typesynopsis ${$I}encoding${$NI} -optional 1 + data -type string -help "binary string" + + @form -form full + @leaders -min 0 -max 0 + @opts + -profile -type string -typesynopsis ${$I}profile${$NI} -help\ + "Determines the command behavior in the presence of conversion errors. + Any premature termination of processing due to errors is reported through an exception + if the -failindex option is not specified. + + Operations involving encoding transforms may encounter several types of errors such as + invalid sequences in the source data, characters that cannot be encoded in the target + encoding and so on. A profile prescribes the strategy for dealing with such errors in + one of two ways: + + Terminating further processing of the source data. The profile does not determine how + this premature termination is conveyed to the caller. By default, this is signalled + by raising an exception. If the -failindex option is specified, errors are reported + through that mechanism. + + Continue further processing of the source data using a fallback strategy such as + replacing or discarding the offending bytes in a profile-defined manner. + + The following profiles are currently implemented with strict being the default if the -profile is not specified."\ + -choicecolumns 1\ + -choices {strict tcl8 replace}\ + -choiceprefix 0\ + -choicelabels { + strict + " The strict profile always stops processing when an conversion error is encountered. + The error is signalled via an exception or the -failindex option mechanism. + The strict profile implements a Unicode standard conformant behavior." + tcl8 + " The tcl8 profile always follows the first strategy above and corresponds to the behavior + of encoding transforms in Tcl 8.6. When converting from an external encoding other than + utf-8 to Tcl strings with the encoding convertfrom command, invalid bytes are mapped to + their numerically equivalent code points. For example, the byte 0x80 which is invalid in + ASCII would be mapped to code point U+0080. When converting from utf-8, invalid bytes + that are defined in CP1252 are mapped to their Unicode equivalents while those that are + not fall back to the numerical equivalents. For example, byte 0x80 is defined by CP1252 + and is therefore mapped to its Unicode equivalent U+20AC while byte 0x81 which is not + defined by CP1252 is mapped to U+0081. As an additional special case, the sequence + 0xC0 0x80 is mapped to U+0000. When converting from Tcl strings to an external encoding + format using encoding convertto, characters that cannot be represented in the target + encoding are replaced by an encoding-dependent character, usually the question mark ?." + replace + " Like the tcl8 profile, the replace profile always continues processing on conversion + errors but follows a Unicode standard conformant method for substitution of invalid + source data. When converting an encoded byte sequence to a Tcl string using encoding + convertfrom, invalid bytes are replaced by the U+FFFD REPLACEMENT CHARACTER code point. + When encoding a Tcl string with encoding convertto, code points that cannot be represented + in the target encoding are transformed to an encoding-specific fallback character, U+FFFD + REPLACEMENT CHARACTER for UTF targets and generally `?` for other encodings." + } + -failindex -type string -typesynopsis ${$I}var${$NI} -help\ + "If specified, instead of an exception being raised on premature termination, + the result of the conversion up to the point of the error is returned as the + result of the command. In addition, the index of the source byte triggering + the error is stored in var. If no errors are encountered, the entire result + of the conversion is returned and the value -1 is stored in var." + @values -min 2 -max 2 + encoding -type string -optional 0 + data -type string -help "binary string" + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + + lappend PUNKARGS [list { + @id -id "::tcl::encoding::convertto" + @cmd -name "encoding convertto" -help\ + "Convert string to the specified encoding. The result is a Tcl binary string that + contains the sequence of bytes representing the converted string in the specified + encoding. If encoding is not specified, the current system encoding is used." + @form -form basic + @values -min 1 -max 2 + encoding -type string -typesynopsis ${$I}encoding${$NI} -optional 1 + data -type string + + @form -form full + @leaders -min 0 -max 0 + @opts + ${[punk::args::resolved_def -form 1 -types opts ::tcl::encoding::convertfrom -*]} + @values -min 2 -max 2 + encoding -type string -optional 0 + data -type string + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::dirs" + @cmd -name "encoding dirs" -help\ + "Tcl can load encoding data files from the file system that describe + additional encodings for it to work with. This command sets the search + path for ${$B}*.enc${$N} encoding data files to the list of directories + ${$I}directoryList${$NI}. If ${$I}directoryList${$NI} is omitted then the + command returns the current list of directories that make up the search + path. It is an error for ${$I}directoryList${$NI} to not be a valid list. + If, when a search for an encoding data file is happening, an element in + ${$I}directoryList${$NI} does not refer to a readable, searchable + directory, that element is ignored." + @values -min 0 -max 1 + directoryList -optional 1 -type list + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::names" + @cmd -name "encoding names" -help\ + "Returns a list containing the names of all of the encodings that are + currently available. The encodings “utf-8” and “iso8859-1” are + guaranteed to be present in the list." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::profiles" + @cmd -name "encoding profiles" -help\ + "Returns a list of the names of encoding profiles. See PROFILES below." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::system" + @cmd -name "encoding system" -help\ + "Set the system encoding to ${$I}encoding${$NI}. If ${$I}encoding${$NI} is + omitted then the command returns the current system encoding. + The system encoding is used whenever Tcl passes strings to system calls." + @values -min 0 -max 1 + encoding -type string -optional 1 + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::user" + @cmd -name "encoding user" -help\ + "Returns the name of encoding as per the user's preferences. + On Windows systems, this is based on the user's code page settings in + the registry. On other platforms, the returned value is the same as + returned by encoding system." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } + + lappend PUNKARGS [list { + @id -id ::time + @cmd -name "Built-in: time" -help\ + "Calls the Tcl interpreter count times to evaluate script + (or once if count is not specified). It will then return + a string of the form + 503.2 microseconds per iteration + which indicates the average amount of time required per + iteration, in microseconds. Time is measured in elapsed + time, not CPU time. + (see also: timerate)" + @values -min 1 -max 2 + script -type script + count -type integer -default 1 -optional 1 + } "@doc -name Manpage: -url [manpage_tcl time]" ] + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tcl::chan::blocked + @cmd -name "Built-in: tcl::chan::blocked" -help\ + "This tests whether the last input operation on the channel called ${$I}channel${$NI} + failed because it would otherwise have caused the process to block, and returns 1 + if that was the case. It returns 0 otherwise. Note that this only ever returns 1 + when the channel has been configured to be non-blocking; all Tcl channels have + blocking turned on by default" + @values -min 1 -max 1 + channel -help \ + "" + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::chan::close + @cmd -name "Built-in: tcl::chan::close" -help\ + "Close and destroy the channel called channel. Note that this deletes all existing file-events + registered on the channel. If the direction argument (which must be read or write or any + unique abbreviation of them) is present, the channel will only be half-closed, so that it can + go from being read-write to write-only or read-only respectively. If a read-only channel is + closed for reading, it is the same as if the channel is fully closed, and respectively similar + for write-only channels. Without the direction argument, the channel is closed for both reading + and writing (but only if those directions are currently open). It is an error to close a + read-only channel for writing, or a write-only channel for reading. + As part of closing the channel, all buffered output is flushed to the channel's output device + (only if the channel is ceasing to be writable), any buffered input is discarded (only if the + channel is ceasing to be readable), the underlying operating system resource is closed and + channel becomes unavailable for future use (both only if the channel is being completely closed). + + If the channel is blocking and the channel is ceasing to be writable, the command does not return + until all output is flushed. If the channel is non-blocking and there is unflushed output, the + channel remains open and the command returns immediately; output will be flushed in the + background and the channel will be closed when all the flushing is complete. + + If channel is a blocking channel for a command pipeline then chan close waits for the child + processes to complete. + + If the channel is shared between interpreters, then chan close makes channel unavailable in the + invoking interpreter but has no other effect until all of the sharing interpreters have closed the + channel. When the last interpreter in which the channel is registered invokes chan close (or close), + the cleanup actions described above occur. With half-closing, the half-close of the channel only + applies to the current interpreter's view of the channel until all channels have closed it in that + direction (or completely). See the interp command for a description of channel sharing. + + Channels are automatically fully closed when an interpreter is destroyed and when the process exits. + Channels are switched to blocking mode, to ensure that all output is correctly flushed before the + process exits. + + The command returns an empty string, and may generate an error if an error occurs while flushing + output. If a command in a command pipeline created with open returns an error, chan close generates + an error (similar to the exec command.) + + Note that half-closes of sockets and command pipelines can have important side effects because they + result in a shutdown() or close() of the underlying system resource, which can change how other + processes or systems respond to the Tcl program. + + Channels are automatically closed when an interpreter is destroyed and when the process exits. + From 8.6 on (TIP#398), nonblocking channels are no longer switched to blocking mode when exiting; + this guarantees a timely exit even when the peer or a communication channel is stalled. To ensure + proper flushing of stalled nonblocking channels on exit, one must now either (a) actively switch + them back to blocking or (b) use the environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT, which when + set and not equal to “0” restores the previous behavior." + @values -min 1 -max 1 + channel + direction -optional 1 -choices {read write} + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + lappend PUNKARGS [list { + @id -id ::fconfigure + @cmd -name "Built-in: chan configure" -help\ + "Query or set the configuration options of the channel named ${$I}channel${$NI} + If no ${$I}optionName${$NI} or ${$I}value${$NI} arguments are supplied, the + command returns a list containing alternating option names and values for the + channel. If ${$I}optionName${$NI} is supplied but no ${$I}value${$NI} then the + command returns the current value of the given option. If one or more pairs + of ${$I}optionName${$NI} and ${$I}value${$NI} are supplied, the command sets each + of the named options to the corresponding value; in this case the return + value is an empty string. + + The options described below are supported for all channels. In addition, each + channel type may add options that only it supports. See the manual entry for + the command that creates each type of channel for the options supported by + that specific type of channel. For example, see the manual entry for the + ${$B}socket${$N} command for additional options for sockets, and the ${$B}open${$N} + command for additional options for serial devices. + ${$B}-blocking${$N} ${$I}boolean${$NI} + The ${$B}-blocking${$N} option determines whether I/O operations on the + channel can cause the process to block indefinitely. The value of the + option must be a proper boolean value. Channels are normally in blocking + mode; if a channel is placed into non-blocking mode it will affect the + operation of the ${$B}chan gets, chan read, chan puts, chan flush,${$N} + and ${$B}chan close${$N} commands; see the documentation for those + commands for details. For non-blocking mode to work correctly, the + application must be using the Tcl event loop (e.g. by calling + ${$B}Tcl_DoOneEvent${$N} or invoking the ${$B}vwait${$N} command). + ${$B}-buffering${$N} ${$I}newValue${$NI} + If ${$I}newValue${$NI} is ${$B}full${$N} then the I/O system will buffer output until its + internal buffer is full or until the ${$B}chan flush${$N} command is invoked. If + ${$I}newValue${$NI} is ${$B}line${$N}, then the I/O system will automatically flush output for + the channel whenever a newline character is output. If ${$I}newValue${$NI} is ${$B}none${$N}, + the I/O system will flush automatically after every output operation. The + default is for ${$B}-buffering${$N} to be set to ${$B}full${$N} except for channels that + connect to terminal-like devices; for these channels the initial setting + is ${$B}line${$N}. Additionally, ${$B}stdin${$N} and ${$B}stdout${$N} are initially set to ${$B}line${$N}, and + ${$B}stderr${$N} is set to ${$B}none${$N}. + ${$B}-buffersize${$N} ${$I}newSize${$NI} + ${$I}newSize${$NI} must be an integer; its value is used to set the size of buffers, + in bytes, subsequently allocated for this channel to store input or output. + ${$I}newSize${$NI} must be a number of no more than one million, allowing buffers of + up to one million bytes in size. + ${$B}-encoding${$N} ${$I}name${$NI} + + ${$B}-eofchar${$N} ${$I}char${$NI} + + ${$B}-profile${$N} ${$I}profile${$NI} + + ${$B}-translation${$N} ${$I}translation${$NI}" + + @form -form {getall} + @values -min 1 -max 1 + channel + @form -form {getone} + @values -min 2 -max 2 + channel + optionName + + @form -form {set} + @values -min 3 -max -1 + channel + "optionName value" -type {string any} -typesynopsis {${$I}optionName value${$NI}} -multiple 1 -optional 0 + + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + + + lappend PUNKARGS [list { + @id -id ::tcl::chan::eof + @cmd -name "Built-in: tcl::chan::eof"\ + -summary\ + "Check for end of file condition on channel"\ + -help\ + "Test whether the last input operation on the channel called ${$I}channel${$NI} + failed because the end of the data stream was reached, returning 1 if end-of-file + was reached, and 0 otherwise." + @values -min 1 -max 1 + channel -help \ + "" + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + #event + lappend PUNKARGS [list { + @id -id ::tcl::chan::flush + @cmd -name "Built-in: tcl::chan::flush"\ + -summary\ + "Flush pending output."\ + -help\ + "Ensures that all pending output for the channel called channel is written. + If the channel is in blocking mode the command does not return until all the buffered output + has been flushed to the channel. If the channel is in non-blocking mode, the command may + return before all buffered output has been flushed; the remainder will be flushed in the + background as fast as the underlying file or device is able to absorb it." + @values -min 1 -max 1 + channel + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::chan::gets + @cmd -name "Built-in: tcl::chan::gets"\ + -summary\ + "Read a line from channel."\ + -help\ + "Reads a line from the channel consisting of all characters up to the next end-of-line sequence + or until end of file is seen. The line feed character corresponding to end-of-line sequence is + not included as part of the line. If the varName argument is specified, the line is stored in + the variable of that name and the command returns the length of the line. If varName is not + specified, the command returns the line itself as the result of the command. + If a complete line is not available and the channel is not at EOF, the command will block in the + case of a blocking channel. For non-blocking channels, the command will return the empty string + as the result in the case of varName not specified and -1 if it is. + + If a blocking channel is already at EOF, the command returns an empty string if varName is not + specified. Note an empty string result can also be returned when a blank line (no characters + before the next end of line sequence). The two cases can be distinguished by calling the chan eof + command to check for end of file. If varName is specified, the command returns -1 on end of file. + There is no ambiguity in this case because blank lines result in 0 being returned. + + If a non-blocking channel is already at EOF, the command returns an empty line if varName is not + specified. This can be distinguished from an empty line being returned by either a blank line + being read or a full line not being available through the use of the chan eof and chan blocked + commands. If chan eof returns true, the channel is at EOF. If chan blocked returns true, a full + line was not available. If both commands return false, an empty line was read. If varName was + specified for a non-bocking channel at EOF, the command returns -1. This can be distinguished + from full line not being available either by chan eof or chan blocked as above. Note that when + varName is specified, there is no need to distinguish between eof and blank lines as the latter + will result in the command returning 0. + + If the encoding profile strict is in effect for the channel, the command will raise an exception + with the POSIX error code EILSEQ if any encoding errors are encountered in the channel input data. + The file pointer remains unchanged and it is possible to introspect, and in some cases recover, by + changing the encoding in use" + @values -min 1 -max 2 + channel + varName -optional 1 + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + #isbinary + #names + #pending + lappend PUNKARGS [list { + @id -id ::tcl::chan::pipe + @cmd -name "Built-in: tcl::chan::pipe"\ + -summary\ + "Create a standalone pipe."\ + -help\ + "Creates a standalone pipe whose read- and write-side channels are returned + as a 2-element list, the first element being the read side and the second + write side. Can be useful e.g. to redirect separately ${$B}stderr${$N} and ${$B}stdout${$N} + from a subprocess. To do this spawn with \"2>@\" or \">@\" redirection + operators onto the write side of a pipe, and then immediately close it + in the parent. This is necessary to get an EOF on the read side once the + child has exited or otherwise closed its output. + Note that the pipe buffering semantics can vary at the operating system + level substantially; it is not safe to assume that a write performed on + the output side of the pipe will appear instantly to the input side. + This is a fundamental difference and Tcl cannot conceal it. The overall + stream semantics ${$I}are${$NI} compatible, so blocking reads and writes + will not see most of the differences, but the details of what exactly gets + written when are not. This is most likely to show up when using pipelines + for testing; care should be taken to ensure that deadlocks do not occur + and that potential short reads are allowed for." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::chan::pop + @cmd -name "Built-in: tcl::chan::pop"\ + -summary\ + "Remove topmost channel transform."\ + -help\ + "Removes the topmost transformation from the channel ${$I}channel${$NI}, if there is any. + If there are no transformations added to channel, this is equivalent to + ${$B}chan${$N} close of that channel. The result is normally the empty string, but can + be an error in some situations (i.e. where the underlying system stream is + closed and that results in an error)." + @values -min 1 -max 1 + channel -type string + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::chan::puts + @cmd -name "Built-in: tcl::chan::puts"\ + -summary\ + "Write to a channel."\ + -help\ + "Writes ${$I}string${$NI} to the channel named ${$I}channel${$NI} followed by a newline character. A + trailing newline character is written unless the optional flag ${$B}-nonewline${$N} is + given. If channel is omitted, the string is written to the standard output + channel, ${$B}stdout${$N}. + Newline characters in the output are translated by ${$B}chan puts${$N} to platform-specific + end-of-line sequences according to the currently configured value of the + ${$B}-translation${$N} option for the channel (for example, on PCs newlines are normally + replaced with carriage-return-linefeed sequences; see ${$B}chan configure${$N} for details). + + Tcl buffers output internally, so characters written with ${$B}chan puts${$N} may not appear + immediately on the output file or device; Tcl will normally delay output until the + buffer is full or the channel is closed. You can force output to appear + immediately with the ${$B}chan flush${$N} command. + + When the output buffer fills up, the ${$B}chan puts${$N} command will normally block until + all the buffered data has been accepted for output by the operating system. If + channel is in non-blocking mode then the ${$B}chan puts${$N} command will not block even if + the operating system cannot accept the data. Instead, Tcl continues to buffer the + data and writes it in the background as fast as the underlying file or device can + accept it. The application must use the Tcl event loop for non-blocking output to + work; otherwise Tcl never finds out that the file or device is ready for more + output data. It is possible for an arbitrarily large amount of data to be buffered + for a channel in non-blocking mode, which could consume a large amount of memory. + To avoid wasting memory, non-blocking I/O should normally be used in an + event-driven fashion with the ${$B}chan event${$N} command (do not invoke ${$B}chan puts${$N} unless + you have recently been notified via a file event that the channel is ready for more + output data). + + The command will raise an error exception with POSIX error code ${$B}EILSEQ${$N} if the + encoding profile ${$B}strict${$N} is in effect for the channel and the output data cannot be + encoded in the encoding configured for the channel. Data may be partially written + to the channel in this case." + @opts -prefix 0 + -nonewline -type none + @values -min 1 -max 2 + channel -type string -optional 1 + string -type string + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + } + + lappend PUNKARGS [list { + @id -id ::tcl::chan::read + @cmd -name "Built-in: tcl::chan::read"\ + -summary\ + "Read from a channel."\ + -help\ + "In the first form, the result will be the next numChars characters read from the channel named + channel; if numChars is omitted, all characters up to the point when the channel would signal a + failure (whether an end-of-file, blocked or other error condition) are read. In the second form + (i.e. when numChars has been omitted) the flag -nonewline may be given to indicate that any + trailing newline in the string that has been read should be trimmed. + If channel is in non-blocking mode, chan read may not read as many characters as requested: once + all available input has been read, the command will return the data that is available rather + than blocking for more input. If the channel is configured to use a multi-byte encoding, then + there may actually be some bytes remaining in the internal buffers that do not form a complete + character. These bytes will not be returned until a complete character is available or end-of-file + is reached. The -nonewline switch is ignored if the command returns before reaching the end of the + file. + + Chan read translates end-of-line sequences in the input into newline characters according to the + -translation option for the channel (see chan configure above for a discussion on the ways in + which chan configure will alter input). + + When reading from a serial port, most applications should configure the serial port channel to be + non-blocking, like this: + + chan configure channel -blocking 0 + + Then chan read behaves much like described above. Note that most serial ports are comparatively + slow; it is entirely possible to get a readable event for each character read from them. Care + must be taken when using chan read on blocking serial ports: + + chan read channel numChars + In this form chan read blocks until numChars have been received from the serial port. + chan read channel + In this form chan read blocks until the reception of the end-of-file character, see + chan configure -eofchar. If there no end-of-file character has been configured for the + channel, then chan read will block forever. + + If the encoding profile strict is in effect for the channel, the command will raise an exception + with the POSIX error code EILSEQ if any encoding errors are encountered in the channel input data. + If the channel is in blocking mode, the error is thrown after advancing the file pointer to the + beginning of the invalid data. The successfully decoded leading portion of the data prior to the + error location is returned as the value of the -data key of the error option dictionary. If the + channel is in non-blocking mode, the successfully decoded portion of data is returned by the + command without an error exception being raised. A subsequent read will start at the invalid data + and immediately raise a EILSEQ POSIX error exception. Unlike the blocking channel case, the -data + key is not present in the error option dictionary. In the case of exception thrown due to encoding + errors, it is possible to introspect, and in some cases recover, by changing the encoding in use. + See ENCODING ERROR EXAMPLES later." + + @form -form readchars + @values -min 1 -max 2 + channel + numChars -type integer -optional 1 + + @form -form read + @opts + -nonewline -type none + @values -min 1 -max 1 + channel + + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::chan::seek + @cmd -name "Built-in: tcl::chan::seek"\ + -summary\ + "Set channel access position as byte offset."\ + -help\ + "Sets the current access position within the underlying data stream for the channel named + channel to be offset bytes relative to origin. + Offset must be an integer (which may be negative) + The origin argument defaults to start. + + Chan seek flushes all buffered output for the channel before the command returns, even if the + channel is in non-blocking mode. It also discards any buffered and unread input. This command + returns an empty string. An error occurs if this command is applied to channels whose + underlying file or device does not support seeking. + + Note that offset values are byte offsets, not character offsets. Both chan seek and chan tell + operate in terms of bytes, not characters, unlike chan read." + @values -min 2 -max 3 + channel + offset -type integer + origin -type string\ + -default start\ + -optional 1\ + -choicecolumns 1\ + -choices {start current end}\ + -choicelabels { + start\ + " The new access position will be offset bytes from the start of the underlying file or device." + current\ + " The new access position will be offset bytes from the current access position; a negative + offset moves the access position backwards in the underlying file or device." + enc\ + " The new access position will be offset bytes from the end of the file or device. A negative + offset places the access position before the end of file, and a positive offset places the + access position after the end of file." + } + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::chan::tell + @cmd -name "Built-in: tcl::chan::tell"\ + -summary\ + "Report channel access position as byte offset."\ + -help\ + "Returns a number giving the current access position within the underlying + data stream for the channel named channel. This value returned is a byte + offset that can be passed to ${[a+ bold]}chan seek${[a+ normal]} in order + to set the channel to a particular position. Note that this value is in + terms of bytes, not characters like ${[a+ bold]}chan read${[a+ normal]}. The + value returned is -1 for channels that do not support seeking." + @values -min 1 -max 1 + channel -help \ + "" + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + + lappend PUNKARGS [list { + @id -id ::tcl::chan::truncate + @cmd -name "Built-in: tcl::chan::truncate"\ + -summary\ + "Truncate channel to specified length or current byte offset."\ + -help\ + "Sets the byte length of the underlying data stream for the channel to be + length (or to the current byte offset within the underlying data stream if + length is omitted). The channel is flushed before truncation." + #todo - auto synopsis? + #@form -synopsis\ + # "chan truncate channel ?length?" + @values -min 1 -max 2 + channel -help \ + "" + length -optional 1 -type integer + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #dict + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tcl::dict::append + @cmd -name "Built-in: tcl::dict::append" -help\ + "This appends the given string (or strings) to the value that the given + key maps to in the dictionary value contained in the given variable, + writing the resulting dictionary value back to that variable. Non-existant + keys are treated as if they map to an empty string. The updated dictionary + value is returned." + @values -min 2 -max -1 + dictionaryVariable -type string -help \ + "" + key + string -type string -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::create + @cmd -name "Built-in: tcl::dict::create" -help\ + "Return a new dictionary that contains each of the key/value mappings listed + as arguments (keys and values alternating, with each key being followed by + its associated value)" + @values -min 2 -max -1 + "key value" -type {string string} -typesynopsis {${$I}key${$NI} ${$I}value${$NI}} -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::exists + @cmd -name "Built-in: tcl::dict::exists" -help\ + "This returns a boolean value indicating whether the given key (or path of + keys through a set of nested dictionaries) exists in the given dictionary + value. This returns a true value exactly when ${$B}dict get${$N} on that path will + succeed." + @values -min 2 -max -1 + dictionaryValue -type dict + key -type string -multiple 1 -optional 0 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::for + @cmd -name "Built-in: tcl::dict::for" -help\ + "This command takes three arguments, the first a two-element list of + variable names (for the key and value respectively of each mapping in + the dictionary), the second the dictionary value to iterate across, and + the third a script to be evaluated for each mapping with the key and + value variable set appropriately (in the manner of ${$B}foreach${$N}). + The result of the command is an empty string. If any evlauation of the + body generates a ${$B}TCL_BREAK${$N} result, no further pairs from the + dictionary will be iterated over and the ${$B}dict for${$N} command will + terminate successfully immediately. If any evaluation of the body generates + a ${$B}TCL_CONTINUE${$N} result, this shall be treated exactly like a + normal ${$B}TCL_OK${$N} result. The order of iteration is the order in which + the keys were inserted into the dictionary." + @values -min 3 -max 3 + "{keyVariable valueVariable}" -type list -minsize 2 -maxsize 2 + dictionaryValue -type dict + body -type string -help\ + "Tcl script" + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::tcl::dict::get + @cmd -name "Built-in: tcl::dict::get" -help\ + "Given a dictionary value (first argument) and a key (second argument), this + will retrieve the value for that key. Where several keys are supplied, the + behaviour of the command shall be as if the result of ${$B}dict get $dictVal $key${$N} + was passed as the first argument to ${$B}dict get${$N} with the remaining + arguments as second (and possibly subsequent) arguments. This facilitates + lookups in nested dictionaries. For example, the following two commands are + equivalent: + ${[punk::args::moduledoc::tclcore::argdoc::example { + dict get $dict foo bar spong + dict get [dict get [dict get $dict foo] bar] spong\ + } + ]} + If no keys are provided, ${$B}dict get${$N} will return a list containing pairs + of elements in a manner similar to ${$B}array get${$N}. That is, the first + element of each pair would be the key and the second element would be the value + for that key. + It is an error to attempt to retrieve a value for a key that is not present in + the dictionary. + " + @values -min 1 -max -1 + dictionaryValue -type dict + key -type string -multiple 1 -optional 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::tcl::dict::getdef + @cmd -name "Built-in: tcl::dict::getdef" -help\ + "This behaves the same as ${$B}dict get${$N} (with at least one ${$I}key${$NI} argument), + returning the value that the key path maps to in the dictionary + ${$I}dictionaryValue${$NI}, except that instead of producing an error because the + ${$I}key${$NI} (or one of the ${$I}key${$NI}s on the key path) is absent, it returns the + ${$I}default${$NI} argument instead. + Note that there must always be at least one ${$I}key${$NI} provided, and that ${$B}dict getdef${$N} and + ${$B}dict getwithdefault${$N} are aliases for each other." + @values -min 1 -max -1 + dictionaryValue -type dict + key -type string -multiple 1 -optional 0 + default -type any -optional 0 + } "@doc -name Manpage: -url [manpage_tcl dict]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #use getdef to define getwithdefault + punk::args::define [punk::args::resolved_def -override {@id { + -id ::tcl::dict::getwithdefault + } @cmd { + -name "Built-in: tcl::dict::getwithdefault" + }} ::tcl::dict::getdef] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::incr + @cmd -name "Built-in: tcl::dict::incr" -help\ + "This adds the given ${$I}increment${$NI} value (an integer that defaults to 1 if + not specified) to the value that the given key maps to in the dictionary + value contained in the given variable, writing the resulting dictionary + value back to that variable. Non-existent keys are treated as if they + map to 0. It is an error to increment a value for an existing key if that + value is not an integer. The updated dictionary value is returned. If + ${$I}dictionaryVariable${$NI} indicates an element that does not exist of an array + that has a default value set, the default value and will be used as the + value of the dictionary prior to the incrementing operation." + @values -min 2 -max 3 + dictionaryVariable -type string + key -type any + increment -type integer -default 1 -optional 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::info + @cmd -name "Built-in: tcl::dict::info" -help\ + "This returns information (intended for display to people) about the + given dictionary though the format of this data is dependent on the + implementation of the dictionary. For dictionaries that are implemented + by hash tables, it is expected that this will return the string produced + by ${$B}Tcl_HashStats${$N}, similar to ${$B}array statistics${$N}." + @values -min 1 -max 1 + dictionaryValue -type dict + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::keys + @cmd -name "Built-in: tcl::dict::keys" -help\ + "Return a list of all keys in the given dictionary value. If a pattern is + supplied, only those keys that match it (according to the rules of ${$B}string + match${$N}) will be returned. The returned keys will be in the order that they + were inserted into the dictionary." + @values -min 1 -max 2 + dictionaryValue -type dict + globPattern -type string -optional 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::lappend + @cmd -name "Built-in: tcl::dict::lappend" -help\ + "This appends the given items to the list value that the given key maps + to in the dictionary value contained in the given variable, writing the + resulting dictionary value back to that variable. Non-existent keys are + treated as if they map to an empty list, and it is legal for there to be + no items to append to the list. It is an error for the value that the key + maps to to not be representable as a list. The updated dictionary value + is returned. If ${$I}dictionaryVariable${$NI} indicates an element that does not + exist of an array that has a default value set, the default value and + will be used as the value of the dictionary prior to the list-appending + operation." + @values -min 2 -max -1 + dictionaryVariable -type dict + key -type any + value -type any -multiple 1 -optional 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::map + @cmd -name "Built-in: tcl::dict::map" -help\ + "This command applies a transformation to each element of a dictionary, + returning a new dictionary. It takes three arguments: the first is a + two-element list of variable names (for the key and value respectively of + each mapping in the dictionary), the second the dictionary value to + iterate across, and the third a script to be evaluated for each mapping + with the key and value variables set appropriately (in the manner of ${$B}lmap${$N}). + In an iteration where the evaluated script completes normally (${$B}TCL_OK${$N}, as + opposed to an ${$B}error${$N}, etc.) the result of the script is put into an + accumulator dictionary using the key that is the current contents of the + keyVariable variable at that point. The result of the ${$B}dict map${$N} command is + the accumulator dictionary after all keys have been iterated over. + + If the evaluation of the body for any particular step generates a break, + no further pairs from the dictionary will be iterated over and the ${$B}dict + map${$N} command will terminate successfully immediately. If the evaluation of + the body for a particular step generates a continue result, the current + iteration is aborted and the accumulator dictionary is not modified. The + order of iteration is the natural order of the dictionary (typically the + order in which the keys were added to the dictionary; the order is the + same as that used in ${$B}dict for${$N})." + @values -min 3 -max 3 + "{keyVariable valueVariable}" -type list -minsize 2 -maxsize 2 + dictionaryValue -type dict + body -type script + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::merge + @cmd -name "Built-in: tcl::dict::merge" -help\ + "Return a dictionary that contains the contents of each of the + ${$I}dictionaryValue${$NI} arguments. Where two (or more) dictionaries + contain a mapping for the same key, the resulting dictionary maps that + key to the value according to the last dictionary on the command line + containing a mapping for that key." + @values -min 0 -max -1 + dictionaryValue -type dict -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::remove + @cmd -name "Built-in: tcl::dict::remove" -help\ + "Return a new dictionary that is a copy of an old one passed in as first + argument except without mappings for each of the keys listed. It is legal + for there to be no keys to remove, and it also legal for any of the keys + to be removed to not be present in the input dictionary in the first place." + @values -min 1 -max -1 + dictionaryValue -type dict + key -type any -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::replace + @cmd -name "Built-in: tcl::dict::replace" -help\ + "Return a new dictionary that is a copy of an old one passed in as first + argument except with some values different or some extra key/value pairs + added. It is legal for this command to be called with no key/value pairs, + but illegal for this command to be called with a key but no value." + @values -min 1 -max -1 + dictionaryValue -type dict + "key value" -type {any any} -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::set + @cmd -name "Built-in: tcl::dict::set" -help\ + "This operation takes the name of a variable containing a dictionary value + and places an updated dictionary value in that variable containing a + mapping from the given key to the given value. When multiple keys are + present, this operation creates or updates a chain of nested dictionaries. + The updated dictionary value is returned. If ${$I}dictionaryVariable${$NI} indicates + an element that does not exist of an array that has a default value set, + the default value and will be used as the value of the dictionary prior to + the value insert/update operation." + @values -min 3 -max -1 + dictionaryVariable -type string + key -type string -optional 0 -multiple 1 + value -type any + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::size + @cmd -name "Built-in: tcl::dict::size" -help\ + "Return the number of key/value mappings in the given dictionary value." + @values -min 1 -max 1 + dictionaryValue -type dict + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::unset + @cmd -name "Built-in: tcl::dict::unset" -help\ + "This operation (the companion to ${$B}dict set${$NI}) takes the name of a variable + containing a dictionary value and places an updated dictionary value in + that variable that does not contain a mapping for the given key. Where + multiple keys are present, this describes a path through nested + dictionaries to the mapping to remove. At least one key must be specified, + but the last key on the key-path need not exist. All other components on + the path must exist. The updated dictionary value is returned. If + ${$I}dictionaryVariable${$NI} indicates an element that does not exist of an array + that has a default value set, the default value and will be used as the + value of the dictionary prior to the value remove operation." + @values -min 2 -max -1 + dictionaryVariable -type string + key -type string -optional 0 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::update + @cmd -name "Built-in: tcl::dict::update" -help\ + "Execute the Tcl script in ${$I}body${$NI} with the value for each ${$I}key${$NI} (as found by + reading the dictionary value in ${$I}dictionaryVariable${$NI}) mapped to the variable + ${$I}varName${$NI}. There may be multiple ${$I}key/varName${$NI} pairs. If a ${$I}key${$NI} does not have a + mapping, that corresponds to an unset ${$I}varName${$NI}. When ${$I}body${$NI} terminates, any + changes made to the ${$I}varName${$NI}s is reflected back to the dictionary within + ${$I}dictionaryVariable${$NI} (unless ${$I}dictionaryVariable${$NI} itself becomes unreadable, + when all updates are silently discarded), even if the result of ${$I}body${$NI} is an + error or some other kind of exceptional exit. The result of dict update is + (unless some kind of error occurs) the result of the evaluation of ${$I}body${$NI}. + If ${$I}dictionaryVariable${$NI} indicates an element that does not exist of an array + that has a default value set, the default value and will be used as the + value of the dictionary prior to the update operation. + + Each ${$I}varName${$NI} is mapped in the scope enclosing the dict update; it is + recommended that this command only be used in a local scope (${$B}proc${$N}edure, + lambda term for ${$B}apply${$N}, or method). Because of this, the variables set by + ${$B}dict update${$N} will continue to exist after the command finishes (unless + explicitly unset). + + Note that the mapping of values to variables does not use traces; changes + to the ${$I}dictionaryVariable${$NI}'s contents only happen when ${$I}body${$NI} terminates." + @values -min 4 -max -1 + dictionaryVariable -type string + "key varName" -type {any any} -typesynopsis {${$I}key${$NI} ${$I}varName${$NI}} -optional 0 -multiple 1 + body -type script -typesynopsis ${$I}body