You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
754 lines
31 KiB
754 lines
31 KiB
package provide patternpredator2 1.2.4 |
|
|
|
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 exist $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 |
|
}
|
|
|