76 changed files with 55064 additions and 13140 deletions
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -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 |
||||
} |
||||
|
||||
|
||||
} |
File diff suppressed because it is too large
Load Diff
@ -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 |
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,161 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: %moduletemplate% |
||||
# |
||||
# 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) %year% |
||||
# |
||||
# @@ Meta Begin |
||||
# Application %pkg% 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license %license% |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval %pkg% { |
||||
variable PUNKARGS |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval %pkg%::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
#tcl::namespace::eval %pkg%::system { |
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval %pkg% { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)%pkg%" |
||||
@package -name "%pkg%" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return %pkg% |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package %pkg% |
||||
description to come.. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "%license%" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::%pkg%::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {%authors%} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_custom-topic {} { |
||||
punk::args::lib::tstr -return string { |
||||
A custom |
||||
topic |
||||
etc |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::%pkg%::about" |
||||
dict set overrides @cmd -name "%pkg%::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About %pkg% |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[%pkg%::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [%pkg%::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::%pkg%::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::%pkg%::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::%pkg% |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide %pkg% [tcl::namespace::eval %pkg% { |
||||
variable pkg %pkg% |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -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 |
||||
} |
||||
|
||||
|
||||
} |
File diff suppressed because it is too large
Load Diff
@ -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 |
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -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 |
||||
} |
||||
|
||||
|
||||
} |
File diff suppressed because it is too large
Load Diff
@ -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 |
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Loading…
Reference in new issue