65 changed files with 16354 additions and 40524 deletions
File diff suppressed because it is too large
Load Diff
@ -1,645 +0,0 @@
|
||||
package provide patterncmd [namespace eval patterncmd { |
||||
variable version |
||||
|
||||
set version 1.2.4 |
||||
}] |
||||
|
||||
|
||||
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} { |
||||
???? |
||||
|
||||
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
@ -1,754 +0,0 @@
|
||||
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 |
||||
} |
||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@ -1,761 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2024 JMN |
||||
# (C) 2009 Path Thoyts <patthyts@users.sourceforge.net> |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::zip 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_punk::zip 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::zip] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::zip |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::zip |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require punk::args |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
#[item] [package {punk::args}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#tcl::namespace::eval punk::zip::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::class}] |
||||
#[para] class definitions |
||||
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
#} |
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::zip { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip}] |
||||
#[para] Core API functions for punk::zip |
||||
#[list_begin definitions] |
||||
|
||||
proc Path_a_atorbelow_b {path_a path_b} { |
||||
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
||||
} |
||||
proc Path_a_at_b {path_a path_b} { |
||||
return [expr {[StripPath $path_a $path_b] eq "." }] |
||||
} |
||||
|
||||
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
||||
if {$prefix eq ""} { |
||||
return $path |
||||
} |
||||
set pathparts [file split $path] |
||||
set prefixparts [file split $prefix] |
||||
if {[llength $prefixparts] >= [llength $pathparts]} { |
||||
return "" |
||||
} |
||||
return [file join \ |
||||
{*}[lrange \ |
||||
$pathparts \ |
||||
[llength $prefixparts] \ |
||||
end]] |
||||
} |
||||
|
||||
#StripPath - borrowed from tcllib fileutil |
||||
# ::fileutil::stripPath -- |
||||
# |
||||
# If the specified path references/is a path in prefix (or prefix itself) it |
||||
# is made relative to prefix. Otherwise it is left unchanged. |
||||
# In the case of it being prefix itself the result is the string '.'. |
||||
# |
||||
# Arguments: |
||||
# prefix prefix to strip from the path. |
||||
# path path to modify |
||||
# |
||||
# Results: |
||||
# path The (possibly) modified path. |
||||
|
||||
if {[string equal $::tcl_platform(platform) windows]} { |
||||
# Windows. While paths are stored with letter-case preserved al |
||||
# comparisons have to be done case-insensitive. For reference see |
||||
# SF Tcllib Bug 2499641. |
||||
|
||||
proc StripPath {prefix path} { |
||||
# [file split] is used to generate a canonical form for both |
||||
# paths, for easy comparison, and also one which is easy to modify |
||||
# using list commands. |
||||
|
||||
set prefix [file split $prefix] |
||||
set npath [file split $path] |
||||
|
||||
if {[string equal -nocase $prefix $npath]} { |
||||
return "." |
||||
} |
||||
|
||||
if {[string match -nocase "${prefix} *" $npath]} { |
||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||
} |
||||
return $path |
||||
} |
||||
} else { |
||||
proc StripPath {prefix path} { |
||||
# [file split] is used to generate a canonical form for both |
||||
# paths, for easy comparison, and also one which is easy to modify |
||||
# using list commands. |
||||
|
||||
set prefix [file split $prefix] |
||||
set npath [file split $path] |
||||
|
||||
if {[string equal $prefix $npath]} { |
||||
return "." |
||||
} |
||||
|
||||
if {[string match "${prefix} *" $npath]} { |
||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||
} |
||||
return $path |
||||
} |
||||
} |
||||
|
||||
proc Timet_to_dos {time_t} { |
||||
#*** !doctools |
||||
#[call [fun Timet_to_dos] [arg time_t]] |
||||
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
||||
#[example { |
||||
# DOS timestamps are 32 bits split into bit regions as follows: |
||||
# 24 16 8 0 |
||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||
#}] |
||||
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
||||
scan $s {%d %d %d %d %d %d} year month day hour min sec |
||||
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
||||
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
||||
} |
||||
|
||||
proc walk {args} { |
||||
#*** !doctools |
||||
#[call [fun walk] [arg ?options?] [arg base]] |
||||
#[para] Walk a directory tree rooted at base |
||||
#[para] the -excludes list can be a set of glob expressions to match against files and avoid |
||||
#[para] e.g |
||||
#[example { |
||||
# punk::zip::walk -exclude {CVS/* *~.#*} library |
||||
#}] |
||||
|
||||
set argd [punk::args::get_dict { |
||||
*proc -name punk::zip::walk |
||||
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
||||
-subpath -default "" |
||||
*values -min 1 -max -1 |
||||
base |
||||
fileglobs -default {*} -multiple 1 |
||||
} $args] |
||||
set base [dict get $argd values base] |
||||
set fileglobs [dict get $argd values fileglobs] |
||||
set subpath [dict get $argd opts -subpath] |
||||
set excludes [dict get $argd opts -excludes] |
||||
|
||||
|
||||
set imatch [list] |
||||
foreach fg $fileglobs { |
||||
lappend imatch [file join $subpath $fg] |
||||
} |
||||
|
||||
set result {} |
||||
#set imatch [file join $subpath $match] |
||||
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] |
||||
foreach file $files { |
||||
set excluded 0 |
||||
foreach glob $excludes { |
||||
if {[string match $glob $file]} { |
||||
set excluded 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$excluded} {lappend result $file} |
||||
} |
||||
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { |
||||
set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] |
||||
if {[llength $subdir_entries]>0} { |
||||
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" |
||||
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash |
||||
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. |
||||
set result [list {*}$result "$dir/" {*}$subdir_entries] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
proc extract_zip_prefix {infile outfile} { |
||||
set inzip [open $infile r] |
||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||
if {[file exists $outfile]} { |
||||
error "outfile $outfile already exists - please remove first" |
||||
} |
||||
chan seek $inzip 0 end |
||||
set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent |
||||
chan seek $inzip 0 start |
||||
#only scan last 64k - cover max signature size?? review |
||||
if {$insize < 65559} { |
||||
set tailsearch_start 0 |
||||
} else { |
||||
set tailsearch_start [expr {$insize - 65559}] |
||||
} |
||||
chan seek $inzip $tailsearch_start start |
||||
set scan [read $inzip] |
||||
#EOCD - End Of Central Directory record |
||||
set start_of_end [string last "\x50\x4b\x05\x06" $scan] |
||||
puts stdout "==>start_of_end: $start_of_end" |
||||
|
||||
if {$start_of_end == -1} { |
||||
#no zip cdr - consider entire file to be the zip prefix |
||||
set baseoffset $insize |
||||
} else { |
||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||
chan seek $inzip $filerelative_eocd_posn |
||||
set cdir_record_plus [read $inzip] ;#can have trailing data |
||||
binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
#rule out a false positive from within a nonzip (e.g plain exe) |
||||
#There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. |
||||
#It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway |
||||
#we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros |
||||
#todo - just search for Pk\5\6\0\0\0\0 in the first place? //review |
||||
if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { |
||||
#review - should keep searching? |
||||
#for now we assume not a zip |
||||
set baseoffset $insize |
||||
} else { |
||||
#use the central dir size to jump back tko start of central dir |
||||
#determine if diroffset is file or archive relative |
||||
|
||||
set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] |
||||
puts stdout "---> [read $inzip 4]" |
||||
if {$filerelative_cdir_start > $eocd(diroffset)} { |
||||
#easy case - 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier |
||||
#though we are assuming zip offsets are not corrupted |
||||
set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] |
||||
} else { |
||||
#hard case - either no prefix - or offsets have been adjusted to be file relative. |
||||
#we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers |
||||
#we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? |
||||
#or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete |
||||
|
||||
#step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) |
||||
#we can't assume they're ordered in any particular way - so we in theory have to look at them all. |
||||
set baseoffset "unknown" |
||||
chan seek $inzip $filerelative_cdir_start start |
||||
#binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
# eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
#load the whole central dir into cdir |
||||
|
||||
#todo! loop through all cdr file headers - find highest offset? |
||||
#tclZipfs.c just looks at first file header in Central Directory |
||||
#looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW |
||||
|
||||
set cdirdata [read $inzip $eocd(dirsize)] |
||||
binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ |
||||
cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ |
||||
cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) |
||||
|
||||
#since we're in this branch - we assume cdir(relativeoffset) is from the start of the file |
||||
chan seek $inzip $cdir(relativeoffset) |
||||
#let's at least check that we landed on a local file header.. |
||||
set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field |
||||
binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ |
||||
lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) |
||||
#dec2hex 67324752 = 4034B50 = PK\3\4 |
||||
puts stdout "1st local file header sig: $lfh(signature)" |
||||
if {$lfh(signature) == 67324752} { |
||||
#looks like a local file header |
||||
#use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) |
||||
set baseoffset $cdir(relativeoffset) |
||||
} |
||||
} |
||||
puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" |
||||
} |
||||
} |
||||
puts stdout "baseoffset: $baseoffset" |
||||
#expect CDFH PK\1\2 |
||||
#above the CDFH - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) |
||||
#above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script |
||||
|
||||
if {![string is integer -strict $baseoffset]} { |
||||
error "unable to determine zip baseoffset of file $infile" |
||||
} |
||||
|
||||
if {$baseoffset < $insize} { |
||||
set out [open $outfile w] |
||||
fconfigure $out -encoding iso8859-1 -translation binary |
||||
chan seek $inzip 0 start |
||||
chan copy $inzip $out -size $baseoffset |
||||
close $out |
||||
close $inzip |
||||
} else { |
||||
close $inzip |
||||
file copy $infile $outfile |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
# Mkzipfile -- |
||||
# |
||||
# FIX ME: should handle the current offset for non-seekable channels |
||||
# |
||||
proc Mkzipfile {zipchan base path {comment ""}} { |
||||
#*** !doctools |
||||
#[call [fun Mkzipfile] [arg zipchan] [arg base] [arg path] [arg ?comment?]] |
||||
#[para] Add a single file to a zip archive |
||||
#[para] The zipchan channel should already be open and binary. |
||||
#[para] You can provide a -comment for the file. |
||||
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. |
||||
|
||||
set fullpath [file join $base $path] |
||||
set mtime [Timet_to_dos [file mtime $fullpath]] |
||||
set utfpath [encoding convertto utf-8 $path] |
||||
set utfcomment [encoding convertto utf-8 $comment] |
||||
set flags [expr {(1<<11)}] ;# utf-8 comment and path |
||||
set method 0 ;# store 0, deflate 8 |
||||
set attr 0 ;# text or binary (default binary) |
||||
set version 20 ;# minumum version req'd to extract |
||||
set extra "" |
||||
set crc 0 |
||||
set size 0 |
||||
set csize 0 |
||||
set data "" |
||||
set seekable [expr {[tell $zipchan] != -1}] |
||||
if {[file isdirectory $fullpath]} { |
||||
set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) |
||||
#set attrex 0x40000010 |
||||
} elseif {[file executable $fullpath]} { |
||||
set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) |
||||
} else { |
||||
set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) |
||||
if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { |
||||
set attr 1 ;# text |
||||
} |
||||
} |
||||
|
||||
if {[file isfile $fullpath]} { |
||||
set size [file size $fullpath] |
||||
if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} |
||||
} |
||||
|
||||
|
||||
set offset [tell $zipchan] |
||||
set local [binary format a4sssiiiiss PK\03\04 \ |
||||
$version $flags $method $mtime $crc $csize $size \ |
||||
[string length $utfpath] [string length $extra]] |
||||
append local $utfpath $extra |
||||
puts -nonewline $zipchan $local |
||||
|
||||
if {[file isfile $fullpath]} { |
||||
# If the file is under 2MB then zip in one chunk, otherwize we use |
||||
# streaming to avoid requiring excess memory. This helps to prevent |
||||
# storing re-compressed data that may be larger than the source when |
||||
# handling PNG or JPEG or nested ZIP files. |
||||
if {$size < 0x00200000} { |
||||
set fin [open $fullpath rb] |
||||
set data [read $fin] |
||||
set crc [zlib crc32 $data] |
||||
set cdata [zlib deflate $data] |
||||
if {[string length $cdata] < $size} { |
||||
set method 8 |
||||
set data $cdata |
||||
} |
||||
close $fin |
||||
set csize [string length $data] |
||||
puts -nonewline $zipchan $data |
||||
} else { |
||||
set method 8 |
||||
set fin [open $fullpath rb] |
||||
set zlib [zlib stream deflate] |
||||
while {![eof $fin]} { |
||||
set data [read $fin 4096] |
||||
set crc [zlib crc32 $data $crc] |
||||
$zlib put $data |
||||
if {[string length [set zdata [$zlib get]]]} { |
||||
incr csize [string length $zdata] |
||||
puts -nonewline $zipchan $zdata |
||||
} |
||||
} |
||||
close $fin |
||||
$zlib finalize |
||||
set zdata [$zlib get] |
||||
incr csize [string length $zdata] |
||||
puts -nonewline $zipchan $zdata |
||||
$zlib close |
||||
} |
||||
|
||||
if {$seekable} { |
||||
# update the header if the output is seekable |
||||
set local [binary format a4sssiiii PK\03\04 \ |
||||
$version $flags $method $mtime $crc $csize $size] |
||||
set current [tell $zipchan] |
||||
seek $zipchan $offset |
||||
puts -nonewline $zipchan $local |
||||
seek $zipchan $current |
||||
} else { |
||||
# Write a data descriptor record |
||||
set ddesc [binary format a4iii PK\7\8 $crc $csize $size] |
||||
puts -nonewline $zipchan $ddesc |
||||
} |
||||
} |
||||
|
||||
#PK\x01\x02 Cdentral directory file header |
||||
#set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 |
||||
set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) |
||||
|
||||
set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ |
||||
$version $flags $method $mtime $crc $csize $size \ |
||||
[string length $utfpath] [string length $extra]\ |
||||
[string length $utfcomment] 0 $attr $attrex $offset] |
||||
append hdr $utfpath $extra $utfcomment |
||||
return $hdr |
||||
} |
||||
|
||||
#### REVIEW!!! |
||||
#JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') |
||||
# we probably want offsets to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) |
||||
#### |
||||
|
||||
# zip::mkzip -- |
||||
# |
||||
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt |
||||
# |
||||
proc mkzip {args} { |
||||
#*** !doctools |
||||
#[call [fun mkzip] [arg ?options?] [arg filename]] |
||||
#[para] Create a zip archive in 'filename' |
||||
#[para] If a file already exists, an error will be raised. |
||||
set argd [punk::args::get_dict { |
||||
*proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" |
||||
*opts |
||||
-return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive |
||||
the option -return pretty is the default and uses the punk::lib pdict/plist system |
||||
to return a formatted list for the terminal |
||||
" |
||||
-zipkit -default 0 -type none -help "" |
||||
-runtime -default "" -help "specify a prefix file |
||||
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip |
||||
will create a self-extracting zip archive from the subdir/ folder. |
||||
" |
||||
-comment -default "" -help "An optional comment for the archive" |
||||
-directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" |
||||
-base -default "" -help "The new zip archive will be rooted in this directory if provided |
||||
it must be a parent of -directory" |
||||
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} |
||||
*values -min 1 -max -1 |
||||
filename -default "" -help "name of zipfile to create" |
||||
globs -default {*} -multiple 1 -help "list of glob patterns to match. |
||||
Only directories with matching files will be included in the archive" |
||||
} $args] |
||||
|
||||
set filename [dict get $argd values filename] |
||||
if {$filename eq ""} { |
||||
error "mkzip filename cannot be empty string" |
||||
} |
||||
if {[regexp {[?*]} $filename]} { |
||||
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name |
||||
error "mkzip filename should not contain glob characters ? *" |
||||
} |
||||
if {[file exists $filename]} { |
||||
error "mkzip filename:$filename already exists" |
||||
} |
||||
dict for {k v} [dict get $argd opts] { |
||||
switch -- $k { |
||||
-comment { |
||||
dict set argd opts $k [encoding convertto utf-8 $v] |
||||
} |
||||
-directory - -base { |
||||
dict set argd opts $k [file normalize $v] |
||||
} |
||||
} |
||||
} |
||||
|
||||
array set opts [dict get $argd opts] |
||||
|
||||
|
||||
if {$opts(-directory) ne ""} { |
||||
if {$opts(-base) ne ""} { |
||||
#-base and -directory have been normalized already |
||||
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { |
||||
error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)" |
||||
} |
||||
set base $opts(-base) |
||||
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] |
||||
} else { |
||||
set base $opts(-directory) |
||||
set relpath "" |
||||
} |
||||
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] |
||||
|
||||
set norm_filename [file normalize $filename] |
||||
set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) |
||||
if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { |
||||
#check that we aren't adding the zipfile to itself |
||||
#REVIEW - now that we open zipfile after scanning - this isn't really a concern! |
||||
#keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) |
||||
#In the case of -force - we may want to delay replacement of original until scan is done? |
||||
|
||||
#try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each |
||||
#1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths |
||||
set self_globs_match 0 |
||||
foreach g [dict get $argd values globs] { |
||||
if {[string match $g [file tail $filename]]} { |
||||
set self_globs_match 1 |
||||
break |
||||
} |
||||
} |
||||
if {$self_globs_match} { |
||||
#still dangerous |
||||
set self_excluded 0 |
||||
foreach e $opts(-exclude) { |
||||
if {[string match $e [file tail $filename]]} { |
||||
set self_excluded 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$self_excluded} { |
||||
#still dangerous - likely to be in resultset - check each path |
||||
#puts stderr "zip file $filename is below directory $opts(-directory)" |
||||
set self_is_matched 0 |
||||
set i 0 |
||||
foreach p $paths { |
||||
set norm_p [file normalize [file join $opts(-directory) $p]] |
||||
if {[Path_a_at_b $norm_filename $norm_p]} { |
||||
set self_is_matched 1 |
||||
break |
||||
} |
||||
incr i |
||||
} |
||||
if {$self_is_matched} { |
||||
puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" |
||||
set paths [lremove $paths $i] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
set paths [list] |
||||
set dir [pwd] |
||||
if {$opts(-base) ne ""} { |
||||
if {![Path_a_atorbelow_b $dir $opts(-base)]} { |
||||
error "punk::zip::mkzip -base $opts(-base) must be above current directory" |
||||
} |
||||
set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] |
||||
} else { |
||||
set relpath "" |
||||
} |
||||
set base $opts(-base) |
||||
|
||||
set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] |
||||
foreach m $matches { |
||||
if {$m eq $filename} { |
||||
#puts stderr "--> excluding $filename" |
||||
continue |
||||
} |
||||
set isok 1 |
||||
foreach e [concat $opts(-exclude) $filename] { |
||||
if {[string match $e $m]} { |
||||
set isok 0 |
||||
break |
||||
} |
||||
} |
||||
if {$isok} { |
||||
lappend paths [file join $relpath $m] |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {![llength $paths]} { |
||||
return "" |
||||
} |
||||
|
||||
set zf [open $filename wb] |
||||
if {$opts(-runtime) ne ""} { |
||||
set rt [open $opts(-runtime) rb] |
||||
fcopy $rt $zf |
||||
close $rt |
||||
} elseif {$opts(-zipkit)} { |
||||
#TODO - update to zipfs ? |
||||
#see modpod |
||||
set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" |
||||
append zkd "package require vfs::zip\n" |
||||
append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" |
||||
append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" |
||||
append zkd " source \[file join \[info script\] main.tcl\]\n" |
||||
append zkd "}\n" |
||||
append zkd \x1A |
||||
puts -nonewline $zf $zkd |
||||
} |
||||
|
||||
#todo - subtract this from the endrec offset.. and any ... ? |
||||
set dataStartOffset [tell $zf] ;#the overall file offset of the start of data section //JMN 2024 |
||||
|
||||
set count 0 |
||||
set cd "" |
||||
|
||||
set members [list] |
||||
foreach path $paths { |
||||
#puts $path |
||||
lappend members $path |
||||
append cd [Mkzipfile $zf $base $path] ;#path already includes relpath |
||||
incr count |
||||
} |
||||
set cdoffset [tell $zf] |
||||
set endrec [binary format a4ssssiis PK\05\06 0 0 \ |
||||
$count $count [string length $cd] $cdoffset\ |
||||
[string length $opts(-comment)]] |
||||
append endrec $opts(-comment) |
||||
puts -nonewline $zf $cd |
||||
puts -nonewline $zf $endrec |
||||
close $zf |
||||
|
||||
set result "" |
||||
switch -exact -- $opts(-return) { |
||||
list { |
||||
set result $members |
||||
} |
||||
pretty { |
||||
if {[info commands showlist] ne ""} { |
||||
set result [plist -channel none members] |
||||
} else { |
||||
set result $members |
||||
} |
||||
} |
||||
none { |
||||
set result "" |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::zip ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::zip::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
#tcl::namespace::eval punk::zip::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::zip [tcl::namespace::eval punk::zip { |
||||
variable pkg punk::zip |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,245 +0,0 @@
|
||||
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# UUIDs are 128 bit values that attempt to be unique in time and space. |
||||
# |
||||
# Reference: |
||||
# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt |
||||
# |
||||
# uuid: scheme: |
||||
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html |
||||
# |
||||
# Usage: uuid::uuid generate |
||||
# uuid::uuid equal $idA $idB |
||||
|
||||
package require Tcl 8.5 |
||||
|
||||
namespace eval uuid { |
||||
variable accel |
||||
array set accel {critcl 0} |
||||
|
||||
namespace export uuid |
||||
|
||||
variable uid |
||||
if {![info exists uid]} { |
||||
set uid 1 |
||||
} |
||||
|
||||
proc K {a b} {set a} |
||||
} |
||||
|
||||
### |
||||
# Optimization |
||||
# Caches machine info after the first pass |
||||
### |
||||
|
||||
proc ::uuid::generate_tcl_machinfo {} { |
||||
variable machinfo |
||||
if {[info exists machinfo]} { |
||||
return $machinfo |
||||
} |
||||
lappend machinfo [clock seconds]; # timestamp |
||||
lappend machinfo [clock clicks]; # system incrementing counter |
||||
lappend machinfo [info hostname]; # spatial unique id (poor) |
||||
lappend machinfo [pid]; # additional entropy |
||||
lappend machinfo [array get ::tcl_platform] |
||||
|
||||
### |
||||
# If we have /dev/urandom just stream 128 bits from that |
||||
### |
||||
if {[file exists /dev/urandom]} { |
||||
set fin [open /dev/urandom r] |
||||
binary scan [read $fin 128] H* machinfo |
||||
close $fin |
||||
} elseif {[catch {package require nettool}]} { |
||||
# More spatial information -- better than hostname. |
||||
# bug 1150714: opening a server socket may raise a warning messagebox |
||||
# with WinXP firewall, using ipconfig will return all IP addresses |
||||
# including ipv6 ones if available. ipconfig is OK on win98+ |
||||
if {[string equal $::tcl_platform(platform) "windows"]} { |
||||
catch {exec ipconfig} config |
||||
lappend machinfo $config |
||||
} else { |
||||
catch { |
||||
set s [socket -server void -myaddr [info hostname] 0] |
||||
K [fconfigure $s -sockname] [close $s] |
||||
} r |
||||
lappend machinfo $r |
||||
} |
||||
|
||||
if {[package provide Tk] != {}} { |
||||
lappend machinfo [winfo pointerxy .] |
||||
lappend machinfo [winfo id .] |
||||
} |
||||
} else { |
||||
### |
||||
# If the nettool package works on this platform |
||||
# use the stream of hardware ids from it |
||||
### |
||||
lappend machinfo {*}[::nettool::hwid_list] |
||||
} |
||||
return $machinfo |
||||
} |
||||
|
||||
# Generates a binary UUID as per the draft spec. We generate a pseudo-random |
||||
# type uuid (type 4). See section 3.4 |
||||
# |
||||
proc ::uuid::generate_tcl {} { |
||||
package require md5 2 |
||||
variable uid |
||||
|
||||
set tok [md5::MD5Init] |
||||
md5::MD5Update $tok [incr uid]; # package incrementing counter |
||||
foreach string [generate_tcl_machinfo] { |
||||
md5::MD5Update $tok $string |
||||
} |
||||
set r [md5::MD5Final $tok] |
||||
binary scan $r c* r |
||||
|
||||
# 3.4: set uuid versioning fields |
||||
lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] |
||||
lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] |
||||
|
||||
return [binary format c* $r] |
||||
} |
||||
|
||||
if {[string equal $tcl_platform(platform) "windows"] |
||||
&& [package provide critcl] != {}} { |
||||
namespace eval uuid { |
||||
critcl::ccode { |
||||
#define WIN32_LEAN_AND_MEAN |
||||
#define STRICT |
||||
#include <windows.h> |
||||
#include <ole2.h> |
||||
typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); |
||||
typedef const unsigned char cu_char; |
||||
} |
||||
critcl::cproc generate_c {Tcl_Interp* interp} ok { |
||||
HRESULT hr = S_OK; |
||||
int r = TCL_OK; |
||||
UUID uuid = {0}; |
||||
HMODULE hLib; |
||||
LPFNUUIDCREATE lpfnUuidCreate = NULL; |
||||
hLib = LoadLibraryA(("rpcrt4.dll")); |
||||
if (hLib) |
||||
lpfnUuidCreate = (LPFNUUIDCREATE) |
||||
GetProcAddress(hLib, "UuidCreate"); |
||||
if (lpfnUuidCreate) { |
||||
Tcl_Obj *obj; |
||||
lpfnUuidCreate(&uuid); |
||||
obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); |
||||
Tcl_SetObjResult(interp, obj); |
||||
} else { |
||||
Tcl_SetResult(interp, "error: failed to create a guid", |
||||
TCL_STATIC); |
||||
r = TCL_ERROR; |
||||
} |
||||
return r; |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Convert a binary uuid into its string representation. |
||||
# |
||||
proc ::uuid::tostring {uuid} { |
||||
binary scan $uuid H* s |
||||
foreach {a b} {0 7 8 11 12 15 16 19 20 end} { |
||||
append r [string range $s $a $b] - |
||||
} |
||||
return [string tolower [string trimright $r -]] |
||||
} |
||||
|
||||
# Convert a string representation of a uuid into its binary format. |
||||
# |
||||
proc ::uuid::fromstring {uuid} { |
||||
return [binary format H* [string map {- {}} $uuid]] |
||||
} |
||||
|
||||
# Compare two uuids for equality. |
||||
# |
||||
proc ::uuid::equal {left right} { |
||||
set l [fromstring $left] |
||||
set r [fromstring $right] |
||||
return [string equal $l $r] |
||||
} |
||||
|
||||
# Call our generate uuid implementation |
||||
proc ::uuid::generate {} { |
||||
variable accel |
||||
if {$accel(critcl)} { |
||||
return [generate_c] |
||||
} else { |
||||
return [generate_tcl] |
||||
} |
||||
} |
||||
|
||||
# uuid generate -> string rep of a new uuid |
||||
# uuid equal uuid1 uuid2 |
||||
# |
||||
proc uuid::uuid {cmd args} { |
||||
switch -exact -- $cmd { |
||||
generate { |
||||
if {[llength $args] != 0} { |
||||
return -code error "wrong # args:\ |
||||
should be \"uuid generate\"" |
||||
} |
||||
return [tostring [generate]] |
||||
} |
||||
equal { |
||||
if {[llength $args] != 2} { |
||||
return -code error "wrong \# args:\ |
||||
should be \"uuid equal uuid1 uuid2\"" |
||||
} |
||||
return [eval [linsert $args 0 equal]] |
||||
} |
||||
default { |
||||
return -code error "bad option \"$cmd\":\ |
||||
must be generate or equal" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# LoadAccelerator -- |
||||
# |
||||
# This package can make use of a number of compiled extensions to |
||||
# accelerate the digest computation. This procedure manages the |
||||
# use of these extensions within the package. During normal usage |
||||
# this should not be called, but the test package manipulates the |
||||
# list of enabled accelerators. |
||||
# |
||||
proc ::uuid::LoadAccelerator {name} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $name { |
||||
critcl { |
||||
if {![catch {package require tcllibc}]} { |
||||
set r [expr {[info commands ::uuid::generate_c] != {}}] |
||||
} |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator package:\ |
||||
must be one of [join [array names accel] {, }]" |
||||
} |
||||
} |
||||
set accel($name) $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Try and load a compiled extension to help. |
||||
namespace eval ::uuid { |
||||
variable e {} |
||||
foreach e {critcl} { |
||||
if {[LoadAccelerator $e]} break |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
package provide uuid 1.0.7 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
@ -1,246 +0,0 @@
|
||||
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# UUIDs are 128 bit values that attempt to be unique in time and space. |
||||
# |
||||
# Reference: |
||||
# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt |
||||
# |
||||
# uuid: scheme: |
||||
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html |
||||
# |
||||
# Usage: uuid::uuid generate |
||||
# uuid::uuid equal $idA $idB |
||||
|
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval uuid { |
||||
variable accel |
||||
array set accel {critcl 0} |
||||
|
||||
namespace export uuid |
||||
|
||||
variable uid |
||||
if {![info exists uid]} { |
||||
set uid 1 |
||||
} |
||||
|
||||
proc K {a b} {set a} |
||||
} |
||||
|
||||
### |
||||
# Optimization |
||||
# Caches machine info after the first pass |
||||
### |
||||
|
||||
proc ::uuid::generate_tcl_machinfo {} { |
||||
variable machinfo |
||||
if {[info exists machinfo]} { |
||||
return $machinfo |
||||
} |
||||
lappend machinfo [clock seconds]; # timestamp |
||||
lappend machinfo [clock clicks]; # system incrementing counter |
||||
lappend machinfo [info hostname]; # spatial unique id (poor) |
||||
lappend machinfo [pid]; # additional entropy |
||||
lappend machinfo [array get ::tcl_platform] |
||||
|
||||
### |
||||
# If we have /dev/urandom just stream 128 bits from that |
||||
### |
||||
if {[file exists /dev/urandom]} { |
||||
set fin [open /dev/urandom r] |
||||
fconfigure $fin -encoding binary |
||||
binary scan [read $fin 128] H* machinfo |
||||
close $fin |
||||
} elseif {[catch {package require nettool}]} { |
||||
# More spatial information -- better than hostname. |
||||
# bug 1150714: opening a server socket may raise a warning messagebox |
||||
# with WinXP firewall, using ipconfig will return all IP addresses |
||||
# including ipv6 ones if available. ipconfig is OK on win98+ |
||||
if {[string equal $::tcl_platform(platform) "windows"]} { |
||||
catch {exec ipconfig} config |
||||
lappend machinfo $config |
||||
} else { |
||||
catch { |
||||
set s [socket -server void -myaddr [info hostname] 0] |
||||
K [fconfigure $s -sockname] [close $s] |
||||
} r |
||||
lappend machinfo $r |
||||
} |
||||
|
||||
if {[package provide Tk] != {}} { |
||||
lappend machinfo [winfo pointerxy .] |
||||
lappend machinfo [winfo id .] |
||||
} |
||||
} else { |
||||
### |
||||
# If the nettool package works on this platform |
||||
# use the stream of hardware ids from it |
||||
### |
||||
lappend machinfo {*}[::nettool::hwid_list] |
||||
} |
||||
return $machinfo |
||||
} |
||||
|
||||
# Generates a binary UUID as per the draft spec. We generate a pseudo-random |
||||
# type uuid (type 4). See section 3.4 |
||||
# |
||||
proc ::uuid::generate_tcl {} { |
||||
package require md5 2 |
||||
variable uid |
||||
|
||||
set tok [md5::MD5Init] |
||||
md5::MD5Update $tok [incr uid]; # package incrementing counter |
||||
foreach string [generate_tcl_machinfo] { |
||||
md5::MD5Update $tok $string |
||||
} |
||||
set r [md5::MD5Final $tok] |
||||
binary scan $r c* r |
||||
|
||||
# 3.4: set uuid versioning fields |
||||
lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] |
||||
lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] |
||||
|
||||
return [binary format c* $r] |
||||
} |
||||
|
||||
if {[string equal $tcl_platform(platform) "windows"] |
||||
&& [package provide critcl] != {}} { |
||||
namespace eval uuid { |
||||
critcl::ccode { |
||||
#define WIN32_LEAN_AND_MEAN |
||||
#define STRICT |
||||
#include <windows.h> |
||||
#include <ole2.h> |
||||
typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); |
||||
typedef const unsigned char cu_char; |
||||
} |
||||
critcl::cproc generate_c {Tcl_Interp* interp} ok { |
||||
HRESULT hr = S_OK; |
||||
int r = TCL_OK; |
||||
UUID uuid = {0}; |
||||
HMODULE hLib; |
||||
LPFNUUIDCREATE lpfnUuidCreate = NULL; |
||||
hLib = LoadLibraryA(("rpcrt4.dll")); |
||||
if (hLib) |
||||
lpfnUuidCreate = (LPFNUUIDCREATE) |
||||
GetProcAddress(hLib, "UuidCreate"); |
||||
if (lpfnUuidCreate) { |
||||
Tcl_Obj *obj; |
||||
lpfnUuidCreate(&uuid); |
||||
obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); |
||||
Tcl_SetObjResult(interp, obj); |
||||
} else { |
||||
Tcl_SetResult(interp, "error: failed to create a guid", |
||||
TCL_STATIC); |
||||
r = TCL_ERROR; |
||||
} |
||||
return r; |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Convert a binary uuid into its string representation. |
||||
# |
||||
proc ::uuid::tostring {uuid} { |
||||
binary scan $uuid H* s |
||||
foreach {a b} {0 7 8 11 12 15 16 19 20 end} { |
||||
append r [string range $s $a $b] - |
||||
} |
||||
return [string tolower [string trimright $r -]] |
||||
} |
||||
|
||||
# Convert a string representation of a uuid into its binary format. |
||||
# |
||||
proc ::uuid::fromstring {uuid} { |
||||
return [binary format H* [string map {- {}} $uuid]] |
||||
} |
||||
|
||||
# Compare two uuids for equality. |
||||
# |
||||
proc ::uuid::equal {left right} { |
||||
set l [fromstring $left] |
||||
set r [fromstring $right] |
||||
return [string equal $l $r] |
||||
} |
||||
|
||||
# Call our generate uuid implementation |
||||
proc ::uuid::generate {} { |
||||
variable accel |
||||
if {$accel(critcl)} { |
||||
return [generate_c] |
||||
} else { |
||||
return [generate_tcl] |
||||
} |
||||
} |
||||
|
||||
# uuid generate -> string rep of a new uuid |
||||
# uuid equal uuid1 uuid2 |
||||
# |
||||
proc uuid::uuid {cmd args} { |
||||
switch -exact -- $cmd { |
||||
generate { |
||||
if {[llength $args] != 0} { |
||||
return -code error "wrong # args:\ |
||||
should be \"uuid generate\"" |
||||
} |
||||
return [tostring [generate]] |
||||
} |
||||
equal { |
||||
if {[llength $args] != 2} { |
||||
return -code error "wrong \# args:\ |
||||
should be \"uuid equal uuid1 uuid2\"" |
||||
} |
||||
return [eval [linsert $args 0 equal]] |
||||
} |
||||
default { |
||||
return -code error "bad option \"$cmd\":\ |
||||
must be generate or equal" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# LoadAccelerator -- |
||||
# |
||||
# This package can make use of a number of compiled extensions to |
||||
# accelerate the digest computation. This procedure manages the |
||||
# use of these extensions within the package. During normal usage |
||||
# this should not be called, but the test package manipulates the |
||||
# list of enabled accelerators. |
||||
# |
||||
proc ::uuid::LoadAccelerator {name} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $name { |
||||
critcl { |
||||
if {![catch {package require tcllibc}]} { |
||||
set r [expr {[info commands ::uuid::generate_c] != {}}] |
||||
} |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator package:\ |
||||
must be one of [join [array names accel] {, }]" |
||||
} |
||||
} |
||||
set accel($name) $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Try and load a compiled extension to help. |
||||
namespace eval ::uuid { |
||||
variable e {} |
||||
foreach e {critcl} { |
||||
if {[LoadAccelerator $e]} break |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
package provide uuid 1.0.8 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
Binary file not shown.
@ -1,3 +1,3 @@
|
||||
0.1.0 |
||||
0.1.1 |
||||
#First line must be a tm version number |
||||
#all other lines are ignored. |
||||
|
||||
@ -1,3 +1,3 @@
|
||||
0.1.2 |
||||
0.1.3 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
|
||||
@ -1,3 +1,3 @@
|
||||
0.12 |
||||
0.14 |
||||
#First line must be a tm version number |
||||
#all other lines are ignored. |
||||
|
||||
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,639 +0,0 @@
|
||||
package provide patterncmd [namespace eval patterncmd { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
|
||||
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 |
||||
} |
||||
|
||||
|
||||
} |
||||
@ -1,645 +0,0 @@
|
||||
package provide patterncmd [namespace eval patterncmd { |
||||
variable version |
||||
|
||||
set version 1.2.4 |
||||
}] |
||||
|
||||
|
||||
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} { |
||||
???? |
||||
|
||||
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 |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
@ -1,664 +0,0 @@
|
||||
package provide patternpredator1 1.0 |
||||
|
||||
proc ::p::internals::trailing, {map command stack i arglist pending} { |
||||
error "trailing ',' is not a valid sequence. If the comma was meant to be an argument, precede it with the -- operator." |
||||
} |
||||
proc ::p::internals::trailing.. {map command stack i arglist pending} { |
||||
error "trailing .. references not implemented." |
||||
} |
||||
|
||||
proc ::p::internals::trailing. {map command _ID_ stack i arglist pending} { |
||||
if {![llength $map]} { |
||||
error "Trailing . but no map - command:'$command' stack:$stack i:$i arglist:$arglist pending:$pending" |
||||
} |
||||
|
||||
|
||||
|
||||
#trailing dot - get reference. |
||||
#puts ">>trailing dot>> map:$map command:$command _ID_:$_ID_ stack:$stack i:$i arglist:$arglist pending:$pending" |
||||
lassign [lindex $map 0] OID alias itemCmd cmd |
||||
|
||||
|
||||
#lassign $command command _ID_ |
||||
|
||||
|
||||
if {$pending eq {}} { |
||||
#no pending operation requiring evaluation. |
||||
|
||||
#presumably we're getting a ref to the object, not a property or method. |
||||
#set traceCmd [::list ::p::objectRef_TraceHandler $cmd $_self $OID] |
||||
#if {[::list {array read write unset} $traceCmd] ni [trace info variable $refname]} { |
||||
# trace add variable $refname {array read write unset} $traceCmd |
||||
#} |
||||
set refname ::p::${OID}::_ref::__OBJECT ;#!todo - avoid potential collision with ref to member named '__OBJECT'. |
||||
#object ref - ensure trace-var is an array upon which the objects methods & properties can be accessed as indices |
||||
array set $refname [list] |
||||
#!todo?- populate array with object methods/properties now? |
||||
|
||||
|
||||
set _ID_ [list i [list this [list [list $OID [list map $map]]]]] |
||||
|
||||
#!todo - review. What if $map is out of date? |
||||
|
||||
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] |
||||
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||
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 |
||||
} |
||||
|
||||
|
||||
#set command $refname |
||||
return $refname |
||||
} else { |
||||
#puts "- 11111111 '$command' '$stack'" |
||||
|
||||
if {[string range $command 0 171] eq "::p::-1::"} { |
||||
#!todo - review/enable this branch? |
||||
|
||||
#reference to meta-member |
||||
|
||||
#STALE map problem!! |
||||
|
||||
puts "\naaaaa command: $command\n" |
||||
|
||||
set field [namespace tail [lindex $command 0]] |
||||
set map [lindex $stack 0] |
||||
set OID [lindex $map 0 0] |
||||
|
||||
|
||||
if {[llength $stack]} { |
||||
set refname ::p::${OID}::_ref::[join [concat $field [lrange $stack 1 end]] +] |
||||
set command [interp alias {} $refname {} {*}$command {*}$stack] |
||||
} else { |
||||
set refname ::p::${OID}::_ref::$field |
||||
set command [interp alias {} $refname {} {*}$command] |
||||
} |
||||
puts "???? command '$command' \n refname '$refname' \n" |
||||
|
||||
} else { |
||||
#Property or Method reference (possibly with curried indices or arguments) |
||||
|
||||
#we don't want our references to look like objects. |
||||
#(If they did, they might be found by namespace tidyup code and treated incorrectly) |
||||
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. |
||||
|
||||
|
||||
#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. |
||||
|
||||
|
||||
if {[llength $stack]} { |
||||
set refname ::p::${OID}::_ref::[join [concat $field $stack] +] |
||||
#puts stdout " ------------>>>> refname:$refname" |
||||
if {[string length $_ID_]} { |
||||
set command [interp alias {} $refname {} $command $_ID_ {*}$stack] |
||||
} else { |
||||
set command [interp alias {} $refname {} $command {*}$stack] |
||||
} |
||||
} else { |
||||
set refname ::p::${OID}::_ref::$field |
||||
#!review - for consistency.. we don't directly return method name. |
||||
if {[string length $_ID_]} { |
||||
set command [interp alias {} $refname {} $command $_ID_] |
||||
} else { |
||||
set command [interp alias {} $refname {} $command] |
||||
} |
||||
} |
||||
|
||||
|
||||
#puts ">>>!>>>> refname $refname \n" |
||||
|
||||
|
||||
#NOTE! - we always create a command alias even if $field is not a method. |
||||
#( |
||||
|
||||
#!todo? - build a list of properties from all interfaces (cache it on object??) |
||||
set iflist [lindex $map 1 0] |
||||
|
||||
|
||||
|
||||
|
||||
set found 0 |
||||
foreach IFID [lreverse $iflist] { |
||||
#if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { |
||||
# set found 1 |
||||
# break |
||||
#} |
||||
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { |
||||
set found 1 |
||||
break |
||||
} |
||||
} |
||||
|
||||
|
||||
if {$found} { |
||||
#property reference |
||||
|
||||
#? |
||||
#set readref [string map [list ::_ref:: ::_ref::(GET) |
||||
#set writeref [string map [list ::_ref:: ::_ref::(SET) |
||||
|
||||
#puts "-2222222222 $refname" |
||||
|
||||
#puts "---HERE! $OID $property ::p::${OID}::_ref::${property}" |
||||
#trace remove variable $refname {read write unset} [list ::p::internals::commandrefMisuse_TraceHandler $alias $field] |
||||
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 |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#!todo - move to within trace info test below.. no need to test for refsync trace if no other trace? |
||||
#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::refsync_TraceHandler $OID $alias "" $field] |
||||
if { [::list {write unset} $Hndlr] ni [trace info variable ::p::${OID}::o_${field}]} { |
||||
trace add variable ::p::${OID}::o_${field} {write unset} $Hndlr |
||||
} |
||||
|
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map] ]]]] |
||||
|
||||
#supply all data in easy-access form so that prop_trace_read is not doing any extra work. |
||||
set get_cmd ::p::${OID}::(GET)$field |
||||
set traceCmd [list ::p::predator::prop_trace_read $get_cmd $_ID_ $refname $field $stack] |
||||
|
||||
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||
|
||||
#synch the refvar with the real var if it exists |
||||
#catch {set $refname [$refname]} |
||||
if {[array exists ::p::${OID}::o_$field]} { |
||||
if {![llength $stack]} { |
||||
#unindexed reference |
||||
array set $refname [array get ::p::${OID}::o_$field] |
||||
} else { |
||||
#refs to nonexistant array members common? (catch vs 'info exists') |
||||
if {[info exists ::p::${OID}::o_${field}([lindex $stack 0])]} { |
||||
set $refname [set ::p::${OID}::o_${field}([lindex $stack 0])] |
||||
} |
||||
} |
||||
} else { |
||||
#catch means retrieving refs to non-initialised props slightly slower. |
||||
set errorInfo_prev $::errorInfo ;#preserve errorInfo across these catches! |
||||
|
||||
if {![llength $stack]} { |
||||
catch {set $refname [set ::p::${OID}::o_$field]} |
||||
} else { |
||||
if {[llength $stack] == 1} { |
||||
catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $stack 0]]} |
||||
} else { |
||||
catch {set $refname [lindex [set ::p::${OID}::o_$field] $stack]} |
||||
} |
||||
} |
||||
|
||||
#! what if someone has put a trace on ::errorInfo?? |
||||
set ::errorInfo $errorInfo_prev |
||||
|
||||
} |
||||
|
||||
trace add variable $refname {read} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::prop_trace_write $_ID_ $OID $alias $refname] |
||||
trace add variable $refname {write} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::prop_trace_unset $_ID_ $OID $alias $refname] |
||||
trace add variable $refname {unset} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::prop_trace_array $_ID_ $OID $alias $refname] |
||||
trace add variable $refname {array} $traceCmd |
||||
|
||||
} |
||||
|
||||
|
||||
} else { |
||||
#matching variable in order to detect attempted use as property and throw error |
||||
#puts "$refname ====> adding refMisuse_traceHandler $alias $field" |
||||
trace add variable $refname {read write unset} [list ::p::internals::commandrefMisuse_TraceHandler $alias $field] |
||||
} |
||||
} |
||||
|
||||
return $command |
||||
} |
||||
} |
||||
|
||||
|
||||
#script to inline at placeholder @reduce_pending_stack@ |
||||
set ::p::internals::reduce_pending_stack { |
||||
if {$pending eq {idx}} { |
||||
if {$OID ne {null}} { |
||||
#pattern object |
||||
#set command [list ::p::${OID}::$itemCmd [dict create i [dict create this [list $OID]]]] |
||||
set command ::p::${OID}::$itemCmd |
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map]]]]] |
||||
#todo: set _ID_ [dict create i [dict create this [list [list $OID - - - {}]]] context {}] |
||||
|
||||
} else { |
||||
set command [list $itemCmd $command] |
||||
} |
||||
} |
||||
if {![llength [info commands [lindex $command 0]]]} { |
||||
set cmdname [namespace tail [lindex $command 0]] |
||||
if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { |
||||
lset command 0 ::p::${OID}::(UNKNOWN) |
||||
#puts stdout "!\n calling UNKNOWN $command $cmdname $stack\n\n" |
||||
|
||||
if {[string length $_ID_]} { |
||||
set interim [uplevel 1 [list {*}$command $_ID_ $cmdname {*}$stack]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
set interim [uplevel 1 [list {*}$command $cmdname {*}$stack]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} |
||||
} else { |
||||
return -code error -errorinfo "1)error running command:'$command' argstack:'$stack'\n - command not found and no 'unknown' handler" "method '$command' not found" |
||||
} |
||||
} else { |
||||
#puts "---??? uplevelling $command $_ID_ $stack" |
||||
|
||||
if {[string length $_ID_]} { |
||||
set interim [uplevel 1 [list {*}$command $_ID_ {*}$stack]] |
||||
} else { |
||||
set interim [uplevel 1 [list {*}$command {*}$stack]] |
||||
} |
||||
#puts "---?2? interim:$interim" |
||||
} |
||||
|
||||
|
||||
|
||||
if {[string first ::> $interim] >= 0} { |
||||
#puts "--- ---> tailcalling $interim [lrange $args $i end]" |
||||
tailcall {*}$interim {*}[lrange $args $i end] ;#don't use a return statement as tailcall implies return |
||||
} else { |
||||
#the interim result is not a pattern object - but the . indicates we should treat it as a command |
||||
#tailcall ::p::internals::predator [list [list {null} {} {lindex} $interim {}]] {*}[lrange $args $i end] |
||||
#set nextmap [list [list {null} {} {lindex} $interim {}]] |
||||
#tailcall ::p::internals::predator [dict create i [dict create this [list null ]] map $nextmap] {*}[lrange $args $i end] |
||||
#tailcall ::p::internals::predator [dict create i [dict create this [list [list null [list]] ]] xmap $nextmap] {*}[lrange $args $i end] |
||||
|
||||
tailcall ::p::internals::predator [dict create i [dict create this [list [list null [list map [list [list {null} {} {lindex} $interim {}]]]] ]] callerinfo ""] {*}[lrange $args $i end] |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
proc ::p::predator1 {subject args} [string map [list @reduce_pending_stack@ $::p::internals::reduce_pending_stack] { |
||||
#set OID [lindex [dict get $subject i this] 0 0] |
||||
|
||||
set this_invocant [lindex [dict get $subject i this] 0] ;#for the role 'this' we assume only one invocant in the list. |
||||
lassign $this_invocant OID this_info |
||||
|
||||
if {$OID ne {null}} { |
||||
#upvar #0 ::p::${OID}::_meta::map map |
||||
#if {![dict exists [lindex [dict get $subject i this] 0 1] map]} { |
||||
# set map [set ::p::${OID}::_meta::map] |
||||
#} else { |
||||
# set map [dict get [lindex [dict get $subject i this] 0 1] map] |
||||
#} |
||||
#seems to be faster just to grab from the variable, than to unwrap from $_ID_ !? |
||||
#set map [set ::p::${OID}::_meta::map] |
||||
|
||||
|
||||
|
||||
# if {![dict exists $this_info map]} { |
||||
set map [set ::p::${OID}::_meta::map] |
||||
#} else { |
||||
# set map [dict get $this_info map] |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
lassign [lindex $map 0] OID alias itemCmd cmd |
||||
|
||||
set cheat 1 |
||||
#------- |
||||
#the common optimised case first. 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 {([llength $args] > 1) && ([lindex $args 0] eq {.}) && ([llength [lsearch -all $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args)} { |
||||
set command ::p::${OID}::[lindex $args 1] |
||||
|
||||
if {![llength [info commands $command]]} { |
||||
if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { |
||||
set cmdname [namespace tail $command] |
||||
lset command 0 ::p::${OID}::(UNKNOWN) |
||||
#return [uplevel 1 [list {*}$command [dict create i [dict create this [list [list $OID [list map $map]]]]] $cmdname {*}[lrange $args 2 end]]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
tailcall {*}$command [dict create i [dict create this [list [list $OID [list map [list [lindex $map 0] {{} {}} ] ] ]]]] $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
return -code error -errorinfo "2)error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$command' not found" |
||||
} |
||||
} else { |
||||
#puts " -->> tailcalling $command [lrange $args 2 end]" |
||||
#tailcall $command [dict create i [dict create this [list [list $OID [list map $map]] ]]] {*}[lrange $args 2 end] |
||||
#tailcall $command [dict create i [dict create this [list [list $OID {}] ]]] {*}[lrange $args 2 end] |
||||
|
||||
#jjj |
||||
#tailcall $command [list i [list this [list [list $OID [list map $map]] ]]] {*}[lrange $args 2 end] |
||||
tailcall $command [list i [list this [list [list $OID [list map [list [lindex $map 0] { {} {} } ]]] ]]] {*}[lrange $args 2 end] |
||||
} |
||||
} |
||||
} |
||||
#------------ |
||||
|
||||
|
||||
if {![llength $args]} { |
||||
#return $map |
||||
return [lindex $map 0 1] |
||||
} elseif {[llength $args] == 1} { |
||||
#short-circuit the single index case for speed. |
||||
if {$args ni {.. . -- - & @}} { |
||||
if {$cheat} { |
||||
|
||||
lassign [lindex $map 0] OID alias itemCmd |
||||
#return [::p::${OID}::$itemCmd [lindex $args 0]] |
||||
#tailcall ::p::${OID}::$itemCmd [dict create i [dict create this [list [list $OID [list map $map]]]]] [lindex $args 0] |
||||
tailcall ::p::${OID}::$itemCmd [list i [list this [list [list $OID [list map $map]]]]] [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 $map |
||||
} |
||||
} |
||||
} else { |
||||
#null OID - assume map is included in the _ID_ dict. |
||||
#set map [dict get $subject map] |
||||
set map [dict get $this_info map] |
||||
|
||||
lassign [lindex $map 0] OID alias itemCmd cmd |
||||
} |
||||
#puts "predator==== subject:$subject args:$args map:$map cmd:$cmd " |
||||
|
||||
|
||||
|
||||
#set map $invocant ;#retain 'invocant' in case we need original caller info.. 'map' is the data for whatever is at base of stack. |
||||
set command $cmd |
||||
set stack [list] |
||||
|
||||
#set operators [list . , ..] ;#(exclude --) |
||||
|
||||
|
||||
#!todo? short-circuit/inline commonest/simplest case {llength $args == 2} |
||||
|
||||
|
||||
set argProtect 0 |
||||
set pending "" ;#pending operator e.g . , idx .. & @ |
||||
set _ID_ "" |
||||
|
||||
set i 0 |
||||
|
||||
while {$i < [llength $args]} { |
||||
set word [lindex $args $i] |
||||
|
||||
if {$argProtect} { |
||||
#argProtect must be checked first. |
||||
# We are here because a previous operator necessitates that this word is an argument, not another operator. |
||||
set argProtect 0 |
||||
lappend stack $word |
||||
if {$pending eq {}} { |
||||
set pending idx ;#An argument only implies the index operator if no existing operator is in effect. (because '>obj $arg' must be equivalent to '>obj . item $arg' |
||||
} |
||||
incr i |
||||
} else { |
||||
switch -- $word {.} { |
||||
#$i is the operator, $i + 1 is the command. |
||||
if {[llength $args] > ($i + 1)} { |
||||
#there is at least a command, possibly args too |
||||
|
||||
if {$pending ne {}} { |
||||
#puts ">>>> >>>>> about to reduce. pending:$pending command:$command _ID_:$_ID_ stack:$stack" |
||||
|
||||
|
||||
#always bounces back into the predator via tailcall |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
if {$OID ne {null}} { |
||||
#set command ::p::${OID}::[lindex $args $i+1] |
||||
#lappend stack [dict create i [dict create this [list $OID]]] |
||||
|
||||
set command ::p::${OID}::[lindex $args $i+1] |
||||
set _ID_ [list i [list this [list [list $OID [list map $map]]]]] |
||||
|
||||
} else { |
||||
#set command [list $command [lindex $args $i+1]] |
||||
lappend stack [lindex $args $i+1] |
||||
} |
||||
set pending . |
||||
set argProtect 0 |
||||
incr i 2 |
||||
} |
||||
} else { |
||||
#this is a trailing . |
||||
#puts "----> MAP $map ,command $command ,stack $stack" |
||||
if {$OID ne {null}} { |
||||
return [::p::internals::trailing. $map $command $_ID_ $stack $i $args $pending] |
||||
} else { |
||||
#!todo - fix. This is broken! |
||||
#the usefulness of a reference to an already-resolved value is questionable.. but for consistency it should probably be made to work. |
||||
|
||||
#for a null object - we need to supply the map in the invocation data |
||||
set command ::p::internals::predator |
||||
|
||||
set this_info [dict create map [list [list {null} {} {lindex} $command {}]] ] |
||||
set this_invocant [list null $this_info] |
||||
|
||||
set _ID_ [dict create i [dict create this [list $this_invocant]] ] |
||||
|
||||
return [::p::internals::trailing. $map $command $_ID_ $stack $i $args $pending] |
||||
} |
||||
} |
||||
} {--} { |
||||
#argSafety operator (see also "," & -* below) |
||||
set argProtect 1 |
||||
incr i |
||||
} {,} { |
||||
set argProtect 1 |
||||
if {$i+1 < [llength $args]} { |
||||
#not trailing |
||||
if {$pending ne {}} { |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
if {$OID ne {null}} { |
||||
#set command [list ::p::[lindex $map 0 0]::$itemCmd [lindex $args $i+1]] |
||||
#set command [list $command . $itemCmd [lindex $args $i+1]] |
||||
|
||||
set stack [list . $itemCmd [lindex $args $i+1]] |
||||
|
||||
set _ID_ "" |
||||
|
||||
#lappend stack [dict create i [dict create this [list $OID]]] |
||||
|
||||
set pending "." |
||||
} else { |
||||
# this is an index operation into what is presumed to be a previously returned standard tcl list. (as opposed to an index operation into a returned pattern object) |
||||
#set command [list $itemCmd $command [lindex $args $i+1]] |
||||
#set command [list ::p::internals::predator [list [list {null} {} {lindex} $command {}]] [lindex $args $i+1] ] |
||||
|
||||
|
||||
#set command ::p::internals::predator |
||||
#set _ID_ [dict create i [dict create this [list null]] map [list [list {null} {} {lindex} [lindex $args $i+1] {}]] ] |
||||
#lappend stack [lindex $args $i+1] |
||||
|
||||
|
||||
set command [list $itemCmd $command] ;#e.g {lindex {a b c}} |
||||
|
||||
#set command ::p::internals::predator |
||||
#set _ID_ [dict create i [dict create this [list null]] map [list [list {null} {} {lindex} $nextcommand {}]]] |
||||
set _ID_ {} |
||||
lappend stack [lindex $args $i+1] |
||||
|
||||
|
||||
set pending "." ;#*not* idx or "," |
||||
} |
||||
|
||||
set argProtect 0 |
||||
incr i 2 |
||||
} |
||||
} else { |
||||
return [::p::internals::trailing, $map $command $stack $i $args $pending] |
||||
} |
||||
} {..} { |
||||
#Metaface operator |
||||
if {$i+1 < [llength $args]} { |
||||
#operator is not trailing. |
||||
if {$pending ne {}} { |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
incr i |
||||
|
||||
#set command [list ::p::-1::[lindex $args $i] [dict create i [dict create this [list $OID]]]] |
||||
set command ::p::-1::[lindex $args $i] |
||||
|
||||
#_ID_ is a list, 1st element being a dict of invocants. |
||||
# Each key of the dict is an invocant 'role' |
||||
# Each value is a list of invocant-aliases fulfilling that role |
||||
#lappend stack [list [list caller [lindex $map 0 1] ]] |
||||
#lappend stack [list [dict create this [lindex $map 0 1]]] ;#'this' being the 'subject' in a standard singledispatch method call. |
||||
#lappend stack [dict create i [dict create this [list [lindex $map 0 1]]]] |
||||
|
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map]]]]] |
||||
|
||||
set pending .. |
||||
incr i |
||||
} |
||||
} else { |
||||
return [::p::internals::trailing.. $map $command $stack $i $args $pending] |
||||
} |
||||
} {&} { |
||||
#conglomeration operator |
||||
if {$i+1 < [llength $args]} { |
||||
if {$pending ne {} } { |
||||
@reduce_pending_stack@ |
||||
|
||||
#set interim [uplevel 1 [list {*}$command {*}$stack]] |
||||
#tailcall {*}$interim {*}[lrange $args $i end] ;#don't use a return statement as tailcall implies return |
||||
} |
||||
|
||||
set command [list ::p::-1::Conglomerate $command] |
||||
lappend stack [lindex $args $i+1] |
||||
set pending & |
||||
incr i |
||||
|
||||
|
||||
|
||||
} else { |
||||
error "trailing & not supported" |
||||
} |
||||
} {@} { |
||||
#named-invocant operator |
||||
if {$i+1 < [llength $args]} { |
||||
if {$pending ne {} } { |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
error "@ not implemented" |
||||
|
||||
set pending @ |
||||
incr i |
||||
} |
||||
} else { |
||||
error "trailing @ not supported" |
||||
} |
||||
} default { |
||||
if {[string index $word 0] ni {. -}} { |
||||
lappend stack $word |
||||
if {$pending eq {}} { |
||||
set pending idx |
||||
} |
||||
incr i |
||||
} else { |
||||
if {[string match "-*" $word]} { |
||||
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||
set argProtect 1 |
||||
lappend stack $word |
||||
incr i |
||||
} else { |
||||
if {([string index $word 0] eq ".") && ([string index $word end] eq ".") } { |
||||
#interface accessor! |
||||
error "interface casts not yet implemented!" |
||||
|
||||
set ifspec [string range $word 1 end] |
||||
if {$ifspec eq "!"} { |
||||
#create 'snapshot' reference with all current interfaces |
||||
|
||||
} else { |
||||
foreach ifname [split $ifspec ,] { |
||||
#make each comma-separated interface-name accessible via the 'casted object' |
||||
|
||||
} |
||||
} |
||||
|
||||
} else { |
||||
#has a leading . only. treat as an argument not an operator. |
||||
lappend stack $word |
||||
if {$pending eq {}} { |
||||
set pending idx |
||||
} |
||||
incr i |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
} |
||||
|
||||
#assert: $pending ne "" |
||||
#(we've run out of args, and if no 'operators' were found, then $pending will have been set to 'idx' - equivalent to '. item' ) |
||||
|
||||
#puts "---> evalling command + stack:'$command' '$stack' (pending:'$pending')" |
||||
if {$pending in {idx}} { |
||||
if {$OID ne {null}} { |
||||
#pattern object |
||||
set command ::p::${OID}::$itemCmd |
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map] ] ]]] |
||||
} else { |
||||
# some other kind of command |
||||
set command [list $itemCmd $command] |
||||
} |
||||
} |
||||
if {![llength [info commands [lindex $command 0]]]} { |
||||
set cmdname [namespace tail [lindex $command 0]] |
||||
if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { |
||||
lset command 0 ::p::${OID}::(UNKNOWN) |
||||
#puts stdout "!\n calling UNKNOWN $command $cmdname $stack\n\n" |
||||
|
||||
if {[string length $_ID_]} { |
||||
tailcall {*}$command $_ID_ $cmdname {*}$stack ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
tailcall {*}$command $cmdname {*}$stack ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} |
||||
} else { |
||||
return -code error -errorinfo "3)error running command:'$command' argstack:'$stack'\n - command not found and no 'unknown' handler" "method '$command' not found" |
||||
} |
||||
} |
||||
#puts "... tailcalling $command $stack" |
||||
if {[string length $_ID_]} { |
||||
tailcall {*}$command $_ID_ {*}$stack |
||||
} else { |
||||
tailcall {*}$command {*}$stack |
||||
} |
||||
}] |
||||
@ -1,754 +0,0 @@
|
||||
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 |
||||
} |
||||
Binary file not shown.
Binary file not shown.
@ -1,673 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2024 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application modpod 0.1.4 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin modpod_module_modpod 0 0.1.4] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require modpod] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of modpod |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by modpod |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require struct::set ;#review |
||||
package require punk::lib |
||||
package require punk::args |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6-}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
|
||||
#changes |
||||
#0.1.4 - when mounting with vfs::zip (because zipfs not available) - mount relative to executable folder instead of module dir |
||||
# (given just a module name it's easier to find exepath than look at package ifneeded script to get module path) |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
|
||||
variable connected |
||||
if {![info exists connected(to)]} { |
||||
set connected(to) list |
||||
} |
||||
variable modpodscript |
||||
set modpodscript [info script] |
||||
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
||||
set connected(self) [file dirname $modpodscript] |
||||
} else { |
||||
#expecting a .tm |
||||
set connected(self) $modpodscript |
||||
} |
||||
variable loadables [info sharedlibextension] |
||||
variable sourceables {.tcl .tk} ;# .tm ? |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace modpod}] |
||||
#[para] Core API functions for modpod |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#old tar connect mechanism - review - not needed? |
||||
proc connect {args} { |
||||
puts stderr "modpod::connect--->>$args" |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::connect |
||||
-type -default "" |
||||
@values -min 1 -max 1 |
||||
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
||||
}] |
||||
catch { |
||||
punk::lib::showdict $argd ;#heavy dependencies |
||||
} |
||||
set opt_path [dict get $argd values path] |
||||
variable connected |
||||
set original_connectpath $opt_path |
||||
set modpodpath [modpod::system::normalize $opt_path] ;# |
||||
|
||||
if {$modpodpath in $connected(to)} { |
||||
return [dict create ok ALREADY_CONNECTED] |
||||
} |
||||
lappend connected(to) $modpodpath |
||||
|
||||
set connected(connectpath,$opt_path) $original_connectpath |
||||
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] |
||||
|
||||
set connected(location,$modpodpath) [file dirname $modpodpath] |
||||
set connected(startdata,$modpodpath) -1 |
||||
set connected(type,$modpodpath) [dict get $argd opts -type] |
||||
set connected(fh,$modpodpath) "" |
||||
|
||||
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
||||
set connected(type,$modpodpath) "unwrapped" |
||||
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
||||
|
||||
} else { |
||||
#connect to .tm but may still be unwrapped version available |
||||
lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||
set this_pkg_tm_folder [file dirname $modpodpath] |
||||
if {$connected(type,$modpodpath) ne "unwrapped"} { |
||||
#Not directly connected to unwrapped version - but may still be redirected there |
||||
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
||||
if {[file exists $unwrappedFolder]} { |
||||
#folder with exact version-match must exist for redirect to 'unwrapped' |
||||
set con(type,$modpodpath) "modpod-redirecting" |
||||
} |
||||
} |
||||
|
||||
} |
||||
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
||||
set connected(tmfile,$modpodpath) |
||||
set tail_segments [list] |
||||
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||
foreach lc_mpath $lcase_modulepaths { |
||||
set mpath_segments [file split $lc_mpath] |
||||
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
||||
break |
||||
} |
||||
} |
||||
if {[llength $tail_segments]} { |
||||
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
||||
} else { |
||||
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
||||
} |
||||
|
||||
switch -exact -- $connected(type,$modpodpath) { |
||||
"modpod-redirecting" { |
||||
#redirect to the unwrapped version |
||||
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
||||
|
||||
} |
||||
"unwrapped" { |
||||
if {[info commands ::thread::id] ne ""} { |
||||
set from [pid],[thread::id] |
||||
} else { |
||||
set from [pid] |
||||
} |
||||
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
||||
return [list ok ""] |
||||
} |
||||
default { |
||||
#autodetect .tm - zip/tar ? |
||||
#todo - use vfs ? |
||||
|
||||
#connect to tarball - start at 1st header |
||||
set connected(startdata,$modpodpath) 0 |
||||
set fh [open $modpodpath r] |
||||
set connected(fh,$modpodpath) $fh |
||||
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
||||
|
||||
if {$connected(startdata,$modpodpath) >= 0} { |
||||
#verify we have a valid tar header |
||||
if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { |
||||
seek $fh $connected(startdata,$modpodpath) start |
||||
return [list ok $fh] |
||||
} else { |
||||
#error "cannot verify tar header" |
||||
#try zipfs |
||||
if {[info commands tcl::zipfs::mount] ne ""} { |
||||
|
||||
} |
||||
} |
||||
} |
||||
lpop connected(to) end |
||||
set connected(startdata,$modpodpath) -1 |
||||
unset connected(fh,$modpodpath) |
||||
catch {close $fh} |
||||
return [dict create err {Does not appear to be a valid modpod}] |
||||
} |
||||
} |
||||
} |
||||
proc disconnect {{modpod ""}} { |
||||
variable connected |
||||
if {![llength $connected(to)]} { |
||||
return 0 |
||||
} |
||||
if {$modpod eq ""} { |
||||
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
||||
set modpod [lindex $connected(to) end] |
||||
} |
||||
|
||||
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
||||
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
||||
return 0 |
||||
} |
||||
if {[string length $connected(fh,$modpod)]} { |
||||
close $connected(fh,$modpod) |
||||
} |
||||
array unset connected *,$modpod |
||||
set connected(to) [lreplace $connected(to) $posn $posn] |
||||
return 1 |
||||
} |
||||
proc get {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::get |
||||
-from -default "" -help "path to pod" |
||||
@values -min 1 -max 1 |
||||
filename |
||||
}] |
||||
set frompod [dict get $argd opts -from] |
||||
set filename [dict get $argd values filename] |
||||
|
||||
variable connected |
||||
#//review |
||||
set modpod [::modpod::system::connect_if_not $frompod] |
||||
set fh $connected(fh,$modpod) |
||||
if {$connected(type,$modpod) eq "unwrapped"} { |
||||
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
||||
if {[string range $filename 0 0 eq "/"]} { |
||||
#absolute path (?) |
||||
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
||||
} else { |
||||
#relative path - use #modpod-xxx as base |
||||
set path [file join $connected(location,$modpod) $filename] |
||||
} |
||||
set fd [open $path r] |
||||
#utf-8? |
||||
#fconfigure $fd -encoding iso8859-1 -translation binary |
||||
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
||||
} else { |
||||
#read from vfs |
||||
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
||||
} |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace modpod ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod::lib { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
proc is_valid_tm_version {versionpart} { |
||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||
if {![catch [list package vcompare $versionparts $versionparts]]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#zipfile is a pure zip at this point - ie no script/exe header |
||||
proc make_zip_modpod {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::lib::make_zip_modpod |
||||
-offsettype -default "archive" -choices {archive file} -help\ |
||||
"Whether zip offsets are relative to start of file or start of zip-data within the file. |
||||
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, |
||||
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) |
||||
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. |
||||
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" |
||||
@values -min 2 -max 2 |
||||
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
||||
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" |
||||
}] |
||||
set zipfile [dict get $argd values zipfile] |
||||
set outfile [dict get $argd values outfile] |
||||
set opt_offsettype [dict get $argd opts -offsettype] |
||||
|
||||
|
||||
set mount_stub [string map [list %offsettype% $opt_offsettype] { |
||||
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. |
||||
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. |
||||
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile> |
||||
if {[catch {file normalize [info script]} modfile]} { |
||||
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
||||
} |
||||
if {$modfile eq "" || ![file exists $modfile]} { |
||||
error "modpod zip stub error. Unable to determine module path" |
||||
} |
||||
set moddir [file dirname $modfile] |
||||
set exedir [file dirname [file normalize [info nameofexecutable]]] |
||||
set mod_and_ver [file rootname [file tail $modfile]] |
||||
lassign [split $mod_and_ver -] moduletail version |
||||
|
||||
#determine module namespace so we can mount appropriately |
||||
proc intersect {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return {}} |
||||
if {[llength $B] > [llength $A]} { |
||||
set res $A |
||||
set A $B |
||||
set B $res |
||||
} |
||||
set res {} |
||||
foreach x $A {set ($x) {}} |
||||
foreach x $B { |
||||
if {[info exists ($x)]} { |
||||
lappend res $x |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
set lcase_tmfile_segments [string tolower [file split $moddir]] |
||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||
foreach lc_mpath $lcase_modulepaths { |
||||
set mpath_segments [file split $lc_mpath] |
||||
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail |
||||
break |
||||
} |
||||
} |
||||
if {[llength $tail_segments]} { |
||||
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
||||
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
||||
} else { |
||||
set fullpackage $moduletail |
||||
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
||||
} |
||||
|
||||
if {[info commands tcl::zipfs::mount] ne ""} { |
||||
#argument order changed to be consistent with vfs::zip::Mount etc |
||||
#early versions: zipfs::Mount mountpoint zipname |
||||
#since 2023-09: zipfs::Mount zipname mountpoint |
||||
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
||||
#This is presumably related to // being interpreted as a network path |
||||
set mountpoints [dict keys [tcl::zipfs::mount]] |
||||
if {"//zipfs:/$mount_at" ni $mountpoints} { |
||||
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
||||
if {[catch { |
||||
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
||||
#puts "tcl::zipfs::mount $modfile $mount_at" |
||||
tcl::zipfs::mount $modfile $mount_at |
||||
} errM]} { |
||||
#try old api |
||||
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
||||
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
||||
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
||||
} |
||||
} |
||||
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
||||
#tcl::zipfs::unmount //zipfs:/$mount_at |
||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||
} |
||||
} |
||||
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
||||
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} else { |
||||
#fallback to slower vfs::zip |
||||
#NB. We don't create the intermediate dirs - but the mount still works |
||||
|
||||
if {![file exists $exedir/$mount_at]} { |
||||
if {[catch {package require vfs::zip} errM]} { |
||||
set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" |
||||
append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." |
||||
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
||||
error $msg |
||||
} else { |
||||
set fd [vfs::zip::Mount $modfile $exedir/$mount_at] |
||||
if {![file exists $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
vfs::zip::Unmount $fd $exedir/$mount_at |
||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||
} |
||||
} |
||||
} |
||||
source $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} |
||||
#zipped data follows |
||||
}] |
||||
#todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? |
||||
append mount_stub \x1A |
||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype |
||||
|
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval modpod::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
#deflate,store only supported |
||||
|
||||
#zipfile here is plain zip - no script/exe prefix part. |
||||
proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { |
||||
set inzip [open $zipfile r] |
||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||
set out [open $outfile w+] |
||||
fconfigure $out -encoding iso8859-1 -translation binary |
||||
puts -nonewline $out $mount_stub |
||||
set stuboffset [tell $out] |
||||
lappend report "stub size: $stuboffset" |
||||
fcopy $inzip $out |
||||
close $inzip |
||||
|
||||
set size [tell $out] |
||||
lappend report "modpod::system::make_mountable_zip" |
||||
lappend report "tmfile : [file tail $outfile]" |
||||
lappend report "output size : $size" |
||||
lappend report "offsettype : $offsettype" |
||||
|
||||
if {$offsettype eq "file"} { |
||||
#make zip offsets relative to start of whole file including prepended script. |
||||
#same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 |
||||
#2025 - zipfs mkimg fixed to use 'archive' offset. |
||||
#not editable by 7z,nanazip,peazip |
||||
|
||||
#we aren't adding any new files/folders so we can edit the offsets in place |
||||
|
||||
#Now seek in $out to find the end of directory signature: |
||||
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
||||
if {$size < 65559} { |
||||
set tailsearch_start 0 |
||||
} else { |
||||
set tailsearch_start [expr {$size - 65559}] |
||||
} |
||||
seek $out $tailsearch_start |
||||
set data [read $out] |
||||
#EOCD - End of Central Directory record |
||||
#PK\5\6 |
||||
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
||||
#set start_of_end [expr {$start_of_end + $seek}] |
||||
#incr start_of_end $seek |
||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||
|
||||
lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" |
||||
|
||||
seek $out $filerelative_eocd_posn |
||||
set end_of_ctrl_dir [read $out] |
||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
|
||||
lappend report "End of central directory: [array get eocd]" |
||||
seek $out [expr {$filerelative_eocd_posn+16}] |
||||
|
||||
#adjust offset of start of central directory by the length of our sfx stub |
||||
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] |
||||
flush $out |
||||
|
||||
seek $out $filerelative_eocd_posn |
||||
set end_of_ctrl_dir [read $out] |
||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
|
||||
# 0x06054b50 - end of central dir signature |
||||
puts stderr "$end_of_ctrl_dir" |
||||
puts stderr "comment_len: $eocd(comment_len)" |
||||
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
||||
lappend report "New dir offset: $eocd(diroffset)" |
||||
lappend report "Adjusting $eocd(totalnum) zip file items." |
||||
catch { |
||||
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
||||
} |
||||
|
||||
seek $out $eocd(diroffset) |
||||
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
||||
set current_file [tell $out] |
||||
set fileheader [read $out 46] |
||||
puts -------------- |
||||
puts [ansistring VIEW -lf 1 $fileheader] |
||||
puts -------------- |
||||
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
|
||||
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
set ::last_header $fileheader |
||||
|
||||
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
||||
puts "ver: $x(version)" |
||||
puts "method: $x(method)" |
||||
|
||||
#PK\1\2 |
||||
#33639248 dec = 0x02014b50 - central directory file header signature |
||||
if { $x(sig) != 33639248 } { |
||||
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
||||
} |
||||
|
||||
foreach size $x(lengths) var {filename extrafield comment} { |
||||
if { $size > 0 } { |
||||
set x($var) [read $out $size] |
||||
} else { |
||||
set x($var) "" |
||||
} |
||||
} |
||||
set next_file [tell $out] |
||||
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
||||
|
||||
seek $out [expr {$current_file+42}] |
||||
puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] |
||||
|
||||
#verify: |
||||
flush $out |
||||
seek $out $current_file |
||||
set fileheader [read $out 46] |
||||
lappend report "old $x(offset) + $stuboffset" |
||||
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
lappend report "new $x(offset)" |
||||
|
||||
seek $out $next_file |
||||
} |
||||
} |
||||
|
||||
close $out |
||||
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
||||
#don't fall over just because of that |
||||
catch { |
||||
punk::lib::showdict -roottype list -chan stderr $report |
||||
} |
||||
#puts [join $report \n] |
||||
return |
||||
} |
||||
|
||||
proc connect_if_not {{podpath ""}} { |
||||
upvar ::modpod::connected connected |
||||
set podpath [::modpod::system::normalize $podpath] |
||||
set docon 0 |
||||
if {![llength $connected(to)]} { |
||||
if {![string length $podpath]} { |
||||
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
||||
} else { |
||||
set docon 1 |
||||
} |
||||
} else { |
||||
if {![string length $podpath]} { |
||||
set podpath [lindex $connected(to) end] |
||||
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
||||
} else { |
||||
if {$podpath ni $connected(to)} { |
||||
set docon 1 |
||||
} |
||||
} |
||||
} |
||||
if {$docon} { |
||||
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
||||
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
||||
} else { |
||||
return $podpath |
||||
} |
||||
} |
||||
#we were already connected |
||||
return $podpath |
||||
} |
||||
|
||||
proc myversion {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
||||
} |
||||
set fname [file tail [file rootname [file normalize $script]]] |
||||
set scriptdir [file dirname $script] |
||||
|
||||
if {![string match "#modpod-*" $fname]} { |
||||
lassign [lrange [split $fname -] end-1 end] _pkgname version |
||||
} else { |
||||
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
||||
if {![string length $version]} { |
||||
#try again on the name of the containing folder |
||||
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
||||
#todo - proper walk up the directory tree |
||||
if {![string length $version]} { |
||||
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
||||
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
||||
} |
||||
} |
||||
} |
||||
|
||||
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
||||
return $version |
||||
} |
||||
|
||||
proc myname {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
||||
} |
||||
return $connected(fullpackage,$script) |
||||
} |
||||
proc myfullname {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
#set script [::tarjar::normalize $script] |
||||
set script [file normalize $script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
||||
} |
||||
return $::tarjar::connected(fullpackage,$script) |
||||
} |
||||
proc normalize {path} { |
||||
#newer versions of Tcl don't do tilde sub |
||||
|
||||
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
||||
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
||||
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
||||
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
||||
set path [file normalize $path] |
||||
#set path [string tolower $path] ;#must do this after file normalize |
||||
return [string map [list $matilda ~] $path] ;#get our tildes back. |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide modpod [namespace eval modpod { |
||||
variable pkg modpod |
||||
variable version |
||||
set version 0.1.4 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -0,0 +1,677 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2024 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application modpod 0.1.5 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin modpod_module_modpod 0 0.1.5] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require modpod] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of modpod |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by modpod |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require struct::set ;#review |
||||
package require punk::lib |
||||
package require punk::args |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6-}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
|
||||
#changes |
||||
#0.1.5 - Reduce pollution of global namespace with procs,variables |
||||
#0.1.4 - when mounting with vfs::zip (because zipfs not available) - mount relative to executable folder instead of module dir |
||||
# (given just a module name it's easier to find exepath than look at package ifneeded script to get module path) |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
|
||||
variable connected |
||||
if {![info exists connected(to)]} { |
||||
set connected(to) list |
||||
} |
||||
variable modpodscript |
||||
set modpodscript [info script] |
||||
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
||||
set connected(self) [file dirname $modpodscript] |
||||
} else { |
||||
#expecting a .tm |
||||
set connected(self) $modpodscript |
||||
} |
||||
variable loadables [info sharedlibextension] |
||||
variable sourceables {.tcl .tk} ;# .tm ? |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace modpod}] |
||||
#[para] Core API functions for modpod |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#old tar connect mechanism - review - not needed? |
||||
proc connect {args} { |
||||
puts stderr "modpod::connect--->>$args" |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::connect |
||||
-type -default "" |
||||
@values -min 1 -max 1 |
||||
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
||||
}] |
||||
catch { |
||||
punk::lib::showdict $argd ;#heavy dependencies |
||||
} |
||||
set opt_path [dict get $argd values path] |
||||
variable connected |
||||
set original_connectpath $opt_path |
||||
set modpodpath [modpod::system::normalize $opt_path] ;# |
||||
|
||||
if {$modpodpath in $connected(to)} { |
||||
return [dict create ok ALREADY_CONNECTED] |
||||
} |
||||
lappend connected(to) $modpodpath |
||||
|
||||
set connected(connectpath,$opt_path) $original_connectpath |
||||
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] |
||||
|
||||
set connected(location,$modpodpath) [file dirname $modpodpath] |
||||
set connected(startdata,$modpodpath) -1 |
||||
set connected(type,$modpodpath) [dict get $argd opts -type] |
||||
set connected(fh,$modpodpath) "" |
||||
|
||||
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
||||
set connected(type,$modpodpath) "unwrapped" |
||||
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
||||
|
||||
} else { |
||||
#connect to .tm but may still be unwrapped version available |
||||
lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||
set this_pkg_tm_folder [file dirname $modpodpath] |
||||
if {$connected(type,$modpodpath) ne "unwrapped"} { |
||||
#Not directly connected to unwrapped version - but may still be redirected there |
||||
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
||||
if {[file exists $unwrappedFolder]} { |
||||
#folder with exact version-match must exist for redirect to 'unwrapped' |
||||
set con(type,$modpodpath) "modpod-redirecting" |
||||
} |
||||
} |
||||
|
||||
} |
||||
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
||||
set connected(tmfile,$modpodpath) |
||||
set tail_segments [list] |
||||
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||
foreach lc_mpath $lcase_modulepaths { |
||||
set mpath_segments [file split $lc_mpath] |
||||
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
||||
break |
||||
} |
||||
} |
||||
if {[llength $tail_segments]} { |
||||
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
||||
} else { |
||||
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
||||
} |
||||
|
||||
switch -exact -- $connected(type,$modpodpath) { |
||||
"modpod-redirecting" { |
||||
#redirect to the unwrapped version |
||||
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
||||
|
||||
} |
||||
"unwrapped" { |
||||
if {[info commands ::thread::id] ne ""} { |
||||
set from [pid],[thread::id] |
||||
} else { |
||||
set from [pid] |
||||
} |
||||
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
||||
return [list ok ""] |
||||
} |
||||
default { |
||||
#autodetect .tm - zip/tar ? |
||||
#todo - use vfs ? |
||||
|
||||
#connect to tarball - start at 1st header |
||||
set connected(startdata,$modpodpath) 0 |
||||
set fh [open $modpodpath r] |
||||
set connected(fh,$modpodpath) $fh |
||||
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
||||
|
||||
if {$connected(startdata,$modpodpath) >= 0} { |
||||
#verify we have a valid tar header |
||||
if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { |
||||
seek $fh $connected(startdata,$modpodpath) start |
||||
return [list ok $fh] |
||||
} else { |
||||
#error "cannot verify tar header" |
||||
#try zipfs |
||||
if {[info commands tcl::zipfs::mount] ne ""} { |
||||
|
||||
} |
||||
} |
||||
} |
||||
lpop connected(to) end |
||||
set connected(startdata,$modpodpath) -1 |
||||
unset connected(fh,$modpodpath) |
||||
catch {close $fh} |
||||
return [dict create err {Does not appear to be a valid modpod}] |
||||
} |
||||
} |
||||
} |
||||
proc disconnect {{modpod ""}} { |
||||
variable connected |
||||
if {![llength $connected(to)]} { |
||||
return 0 |
||||
} |
||||
if {$modpod eq ""} { |
||||
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
||||
set modpod [lindex $connected(to) end] |
||||
} |
||||
|
||||
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
||||
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
||||
return 0 |
||||
} |
||||
if {[string length $connected(fh,$modpod)]} { |
||||
close $connected(fh,$modpod) |
||||
} |
||||
array unset connected *,$modpod |
||||
set connected(to) [lreplace $connected(to) $posn $posn] |
||||
return 1 |
||||
} |
||||
proc get {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::get |
||||
-from -default "" -help "path to pod" |
||||
@values -min 1 -max 1 |
||||
filename |
||||
}] |
||||
set frompod [dict get $argd opts -from] |
||||
set filename [dict get $argd values filename] |
||||
|
||||
variable connected |
||||
#//review |
||||
set modpod [::modpod::system::connect_if_not $frompod] |
||||
set fh $connected(fh,$modpod) |
||||
if {$connected(type,$modpod) eq "unwrapped"} { |
||||
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
||||
if {[string range $filename 0 0 eq "/"]} { |
||||
#absolute path (?) |
||||
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
||||
} else { |
||||
#relative path - use #modpod-xxx as base |
||||
set path [file join $connected(location,$modpod) $filename] |
||||
} |
||||
set fd [open $path r] |
||||
#utf-8? |
||||
#fconfigure $fd -encoding iso8859-1 -translation binary |
||||
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
||||
} else { |
||||
#read from vfs |
||||
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
||||
} |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace modpod ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod::lib { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
proc is_valid_tm_version {versionpart} { |
||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||
if {![catch [list package vcompare $versionparts $versionparts]]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#zipfile is a pure zip at this point - ie no script/exe header |
||||
proc make_zip_modpod {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::lib::make_zip_modpod |
||||
-offsettype -default "archive" -choices {archive file} -help\ |
||||
"Whether zip offsets are relative to start of file or start of zip-data within the file. |
||||
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, |
||||
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) |
||||
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. |
||||
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" |
||||
@values -min 2 -max 2 |
||||
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
||||
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" |
||||
}] |
||||
set zipfile [dict get $argd values zipfile] |
||||
set outfile [dict get $argd values outfile] |
||||
set opt_offsettype [dict get $argd opts -offsettype] |
||||
|
||||
|
||||
#mount_stub should not pollute global namespace. |
||||
set mount_stub [string map [list %offsettype% $opt_offsettype] { |
||||
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. |
||||
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. |
||||
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile> |
||||
if {[catch {file normalize [info script]}]} { |
||||
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
||||
} |
||||
apply {{modfile} { |
||||
if {$modfile eq "" || ![file exists $modfile]} { |
||||
error "modpod zip stub error. Unable to determine module path" |
||||
} |
||||
set moddir [file dirname $modfile] |
||||
set exedir [file dirname [file normalize [info nameofexecutable]]] |
||||
set mod_and_ver [file rootname [file tail $modfile]] |
||||
lassign [split $mod_and_ver -] moduletail version |
||||
set do_intersect {{A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return {}} |
||||
if {[llength $B] > [llength $A]} { |
||||
set res $A |
||||
set A $B |
||||
set B $res |
||||
} |
||||
set res {} |
||||
foreach x $A {set ($x) {}} |
||||
foreach x $B { |
||||
if {[info exists ($x)]} { |
||||
lappend res $x |
||||
} |
||||
} |
||||
return $res |
||||
}} |
||||
#determine module namespace so we can mount appropriately |
||||
set lcase_tmfile_segments [string tolower [file split $moddir]] |
||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||
foreach lc_mpath $lcase_modulepaths { |
||||
set mpath_segments [file split $lc_mpath] |
||||
if {[llength [apply $do_intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail |
||||
break |
||||
} |
||||
} |
||||
if {[llength $tail_segments]} { |
||||
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
||||
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
||||
} else { |
||||
set fullpackage $moduletail |
||||
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
||||
} |
||||
|
||||
if {[info commands tcl::zipfs::mount] ne ""} { |
||||
#argument order changed to be consistent with vfs::zip::Mount etc |
||||
#early versions: zipfs::Mount mountpoint zipname |
||||
#since 2023-09: zipfs::Mount zipname mountpoint |
||||
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
||||
#This is presumably related to // being interpreted as a network path |
||||
set mountpoints [dict keys [tcl::zipfs::mount]] |
||||
if {"//zipfs:/$mount_at" ni $mountpoints} { |
||||
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
||||
if {[catch { |
||||
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
||||
#puts "tcl::zipfs::mount $modfile $mount_at" |
||||
tcl::zipfs::mount $modfile $mount_at |
||||
} errM]} { |
||||
#try old api |
||||
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
||||
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
||||
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
||||
} |
||||
} |
||||
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
||||
#tcl::zipfs::unmount //zipfs:/$mount_at |
||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||
} |
||||
} |
||||
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
||||
uplevel 1 [list source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm] |
||||
} else { |
||||
#fallback to slower vfs::zip |
||||
#NB. We don't create the intermediate dirs - but the mount still works |
||||
|
||||
if {![file exists $exedir/$mount_at]} { |
||||
if {[catch {package require vfs::zip} errM]} { |
||||
set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" |
||||
append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." |
||||
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
||||
error $msg |
||||
} else { |
||||
set fd [vfs::zip::Mount $modfile $exedir/$mount_at] |
||||
if {![file exists $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
vfs::zip::Unmount $fd $exedir/$mount_at |
||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||
} |
||||
} |
||||
} |
||||
uplevel 1 [list source $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm] |
||||
} |
||||
}} [file normalize [info script]] |
||||
|
||||
#zipped data follows |
||||
}] |
||||
#todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? |
||||
append mount_stub \x1A |
||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype |
||||
|
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval modpod::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
#deflate,store only supported |
||||
|
||||
#zipfile here is plain zip - no script/exe prefix part. |
||||
proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { |
||||
set inzip [open $zipfile r] |
||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||
set out [open $outfile w+] |
||||
fconfigure $out -encoding iso8859-1 -translation binary |
||||
puts -nonewline $out $mount_stub |
||||
set stuboffset [tell $out] |
||||
lappend report "stub size: $stuboffset" |
||||
fcopy $inzip $out |
||||
close $inzip |
||||
|
||||
set size [tell $out] |
||||
lappend report "modpod::system::make_mountable_zip" |
||||
lappend report "tmfile : [file tail $outfile]" |
||||
lappend report "output size : $size" |
||||
lappend report "offsettype : $offsettype" |
||||
|
||||
if {$offsettype eq "file"} { |
||||
#make zip offsets relative to start of whole file including prepended script. |
||||
#same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 |
||||
#2025 - zipfs mkimg fixed to use 'archive' offset. |
||||
#not editable by 7z,nanazip,peazip |
||||
|
||||
#we aren't adding any new files/folders so we can edit the offsets in place |
||||
|
||||
#Now seek in $out to find the end of directory signature: |
||||
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
||||
if {$size < 65559} { |
||||
set tailsearch_start 0 |
||||
} else { |
||||
set tailsearch_start [expr {$size - 65559}] |
||||
} |
||||
seek $out $tailsearch_start |
||||
set data [read $out] |
||||
#EOCD - End of Central Directory record |
||||
#PK\5\6 |
||||
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
||||
#set start_of_end [expr {$start_of_end + $seek}] |
||||
#incr start_of_end $seek |
||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||
|
||||
lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" |
||||
|
||||
seek $out $filerelative_eocd_posn |
||||
set end_of_ctrl_dir [read $out] |
||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
|
||||
lappend report "End of central directory: [array get eocd]" |
||||
seek $out [expr {$filerelative_eocd_posn+16}] |
||||
|
||||
#adjust offset of start of central directory by the length of our sfx stub |
||||
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] |
||||
flush $out |
||||
|
||||
seek $out $filerelative_eocd_posn |
||||
set end_of_ctrl_dir [read $out] |
||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
|
||||
# 0x06054b50 - end of central dir signature |
||||
puts stderr "$end_of_ctrl_dir" |
||||
puts stderr "comment_len: $eocd(comment_len)" |
||||
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
||||
lappend report "New dir offset: $eocd(diroffset)" |
||||
lappend report "Adjusting $eocd(totalnum) zip file items." |
||||
catch { |
||||
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
||||
} |
||||
|
||||
seek $out $eocd(diroffset) |
||||
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
||||
set current_file [tell $out] |
||||
set fileheader [read $out 46] |
||||
puts -------------- |
||||
puts [ansistring VIEW -lf 1 $fileheader] |
||||
puts -------------- |
||||
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
|
||||
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
set ::last_header $fileheader |
||||
|
||||
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
||||
puts "ver: $x(version)" |
||||
puts "method: $x(method)" |
||||
|
||||
#PK\1\2 |
||||
#33639248 dec = 0x02014b50 - central directory file header signature |
||||
if { $x(sig) != 33639248 } { |
||||
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
||||
} |
||||
|
||||
foreach size $x(lengths) var {filename extrafield comment} { |
||||
if { $size > 0 } { |
||||
set x($var) [read $out $size] |
||||
} else { |
||||
set x($var) "" |
||||
} |
||||
} |
||||
set next_file [tell $out] |
||||
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
||||
|
||||
seek $out [expr {$current_file+42}] |
||||
puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] |
||||
|
||||
#verify: |
||||
flush $out |
||||
seek $out $current_file |
||||
set fileheader [read $out 46] |
||||
lappend report "old $x(offset) + $stuboffset" |
||||
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
lappend report "new $x(offset)" |
||||
|
||||
seek $out $next_file |
||||
} |
||||
} |
||||
|
||||
close $out |
||||
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
||||
#don't fall over just because of that |
||||
catch { |
||||
punk::lib::showdict -roottype list -chan stderr $report |
||||
} |
||||
#puts [join $report \n] |
||||
return |
||||
} |
||||
|
||||
proc connect_if_not {{podpath ""}} { |
||||
upvar ::modpod::connected connected |
||||
set podpath [::modpod::system::normalize $podpath] |
||||
set docon 0 |
||||
if {![llength $connected(to)]} { |
||||
if {![string length $podpath]} { |
||||
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
||||
} else { |
||||
set docon 1 |
||||
} |
||||
} else { |
||||
if {![string length $podpath]} { |
||||
set podpath [lindex $connected(to) end] |
||||
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
||||
} else { |
||||
if {$podpath ni $connected(to)} { |
||||
set docon 1 |
||||
} |
||||
} |
||||
} |
||||
if {$docon} { |
||||
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
||||
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
||||
} else { |
||||
return $podpath |
||||
} |
||||
} |
||||
#we were already connected |
||||
return $podpath |
||||
} |
||||
|
||||
proc myversion {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
||||
} |
||||
set fname [file tail [file rootname [file normalize $script]]] |
||||
set scriptdir [file dirname $script] |
||||
|
||||
if {![string match "#modpod-*" $fname]} { |
||||
lassign [lrange [split $fname -] end-1 end] _pkgname version |
||||
} else { |
||||
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
||||
if {![string length $version]} { |
||||
#try again on the name of the containing folder |
||||
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
||||
#todo - proper walk up the directory tree |
||||
if {![string length $version]} { |
||||
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
||||
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
||||
} |
||||
} |
||||
} |
||||
|
||||
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
||||
return $version |
||||
} |
||||
|
||||
proc myname {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
||||
} |
||||
return $connected(fullpackage,$script) |
||||
} |
||||
proc myfullname {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
#set script [::tarjar::normalize $script] |
||||
set script [file normalize $script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
||||
} |
||||
return $::tarjar::connected(fullpackage,$script) |
||||
} |
||||
proc normalize {path} { |
||||
#newer versions of Tcl don't do tilde sub |
||||
|
||||
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
||||
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
||||
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
||||
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
||||
set path [file normalize $path] |
||||
#set path [string tolower $path] ;#must do this after file normalize |
||||
return [string map [list $matilda ~] $path] ;#get our tildes back. |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide modpod [namespace eval modpod { |
||||
variable pkg modpod |
||||
variable version |
||||
set version 0.1.5 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -1,639 +0,0 @@
|
||||
package provide patterncmd [namespace eval patterncmd { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
|
||||
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 |
||||
} |
||||
|
||||
|
||||
} |
||||
@ -1,645 +0,0 @@
|
||||
package provide patterncmd [namespace eval patterncmd { |
||||
variable version |
||||
|
||||
set version 1.2.4 |
||||
}] |
||||
|
||||
|
||||
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} { |
||||
???? |
||||
|
||||
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 |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
@ -1,664 +0,0 @@
|
||||
package provide patternpredator1 1.0 |
||||
|
||||
proc ::p::internals::trailing, {map command stack i arglist pending} { |
||||
error "trailing ',' is not a valid sequence. If the comma was meant to be an argument, precede it with the -- operator." |
||||
} |
||||
proc ::p::internals::trailing.. {map command stack i arglist pending} { |
||||
error "trailing .. references not implemented." |
||||
} |
||||
|
||||
proc ::p::internals::trailing. {map command _ID_ stack i arglist pending} { |
||||
if {![llength $map]} { |
||||
error "Trailing . but no map - command:'$command' stack:$stack i:$i arglist:$arglist pending:$pending" |
||||
} |
||||
|
||||
|
||||
|
||||
#trailing dot - get reference. |
||||
#puts ">>trailing dot>> map:$map command:$command _ID_:$_ID_ stack:$stack i:$i arglist:$arglist pending:$pending" |
||||
lassign [lindex $map 0] OID alias itemCmd cmd |
||||
|
||||
|
||||
#lassign $command command _ID_ |
||||
|
||||
|
||||
if {$pending eq {}} { |
||||
#no pending operation requiring evaluation. |
||||
|
||||
#presumably we're getting a ref to the object, not a property or method. |
||||
#set traceCmd [::list ::p::objectRef_TraceHandler $cmd $_self $OID] |
||||
#if {[::list {array read write unset} $traceCmd] ni [trace info variable $refname]} { |
||||
# trace add variable $refname {array read write unset} $traceCmd |
||||
#} |
||||
set refname ::p::${OID}::_ref::__OBJECT ;#!todo - avoid potential collision with ref to member named '__OBJECT'. |
||||
#object ref - ensure trace-var is an array upon which the objects methods & properties can be accessed as indices |
||||
array set $refname [list] |
||||
#!todo?- populate array with object methods/properties now? |
||||
|
||||
|
||||
set _ID_ [list i [list this [list [list $OID [list map $map]]]]] |
||||
|
||||
#!todo - review. What if $map is out of date? |
||||
|
||||
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] |
||||
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||
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 |
||||
} |
||||
|
||||
|
||||
#set command $refname |
||||
return $refname |
||||
} else { |
||||
#puts "- 11111111 '$command' '$stack'" |
||||
|
||||
if {[string range $command 0 171] eq "::p::-1::"} { |
||||
#!todo - review/enable this branch? |
||||
|
||||
#reference to meta-member |
||||
|
||||
#STALE map problem!! |
||||
|
||||
puts "\naaaaa command: $command\n" |
||||
|
||||
set field [namespace tail [lindex $command 0]] |
||||
set map [lindex $stack 0] |
||||
set OID [lindex $map 0 0] |
||||
|
||||
|
||||
if {[llength $stack]} { |
||||
set refname ::p::${OID}::_ref::[join [concat $field [lrange $stack 1 end]] +] |
||||
set command [interp alias {} $refname {} {*}$command {*}$stack] |
||||
} else { |
||||
set refname ::p::${OID}::_ref::$field |
||||
set command [interp alias {} $refname {} {*}$command] |
||||
} |
||||
puts "???? command '$command' \n refname '$refname' \n" |
||||
|
||||
} else { |
||||
#Property or Method reference (possibly with curried indices or arguments) |
||||
|
||||
#we don't want our references to look like objects. |
||||
#(If they did, they might be found by namespace tidyup code and treated incorrectly) |
||||
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. |
||||
|
||||
|
||||
#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. |
||||
|
||||
|
||||
if {[llength $stack]} { |
||||
set refname ::p::${OID}::_ref::[join [concat $field $stack] +] |
||||
#puts stdout " ------------>>>> refname:$refname" |
||||
if {[string length $_ID_]} { |
||||
set command [interp alias {} $refname {} $command $_ID_ {*}$stack] |
||||
} else { |
||||
set command [interp alias {} $refname {} $command {*}$stack] |
||||
} |
||||
} else { |
||||
set refname ::p::${OID}::_ref::$field |
||||
#!review - for consistency.. we don't directly return method name. |
||||
if {[string length $_ID_]} { |
||||
set command [interp alias {} $refname {} $command $_ID_] |
||||
} else { |
||||
set command [interp alias {} $refname {} $command] |
||||
} |
||||
} |
||||
|
||||
|
||||
#puts ">>>!>>>> refname $refname \n" |
||||
|
||||
|
||||
#NOTE! - we always create a command alias even if $field is not a method. |
||||
#( |
||||
|
||||
#!todo? - build a list of properties from all interfaces (cache it on object??) |
||||
set iflist [lindex $map 1 0] |
||||
|
||||
|
||||
|
||||
|
||||
set found 0 |
||||
foreach IFID [lreverse $iflist] { |
||||
#if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { |
||||
# set found 1 |
||||
# break |
||||
#} |
||||
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { |
||||
set found 1 |
||||
break |
||||
} |
||||
} |
||||
|
||||
|
||||
if {$found} { |
||||
#property reference |
||||
|
||||
#? |
||||
#set readref [string map [list ::_ref:: ::_ref::(GET) |
||||
#set writeref [string map [list ::_ref:: ::_ref::(SET) |
||||
|
||||
#puts "-2222222222 $refname" |
||||
|
||||
#puts "---HERE! $OID $property ::p::${OID}::_ref::${property}" |
||||
#trace remove variable $refname {read write unset} [list ::p::internals::commandrefMisuse_TraceHandler $alias $field] |
||||
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 |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#!todo - move to within trace info test below.. no need to test for refsync trace if no other trace? |
||||
#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::refsync_TraceHandler $OID $alias "" $field] |
||||
if { [::list {write unset} $Hndlr] ni [trace info variable ::p::${OID}::o_${field}]} { |
||||
trace add variable ::p::${OID}::o_${field} {write unset} $Hndlr |
||||
} |
||||
|
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map] ]]]] |
||||
|
||||
#supply all data in easy-access form so that prop_trace_read is not doing any extra work. |
||||
set get_cmd ::p::${OID}::(GET)$field |
||||
set traceCmd [list ::p::predator::prop_trace_read $get_cmd $_ID_ $refname $field $stack] |
||||
|
||||
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||
|
||||
#synch the refvar with the real var if it exists |
||||
#catch {set $refname [$refname]} |
||||
if {[array exists ::p::${OID}::o_$field]} { |
||||
if {![llength $stack]} { |
||||
#unindexed reference |
||||
array set $refname [array get ::p::${OID}::o_$field] |
||||
} else { |
||||
#refs to nonexistant array members common? (catch vs 'info exists') |
||||
if {[info exists ::p::${OID}::o_${field}([lindex $stack 0])]} { |
||||
set $refname [set ::p::${OID}::o_${field}([lindex $stack 0])] |
||||
} |
||||
} |
||||
} else { |
||||
#catch means retrieving refs to non-initialised props slightly slower. |
||||
set errorInfo_prev $::errorInfo ;#preserve errorInfo across these catches! |
||||
|
||||
if {![llength $stack]} { |
||||
catch {set $refname [set ::p::${OID}::o_$field]} |
||||
} else { |
||||
if {[llength $stack] == 1} { |
||||
catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $stack 0]]} |
||||
} else { |
||||
catch {set $refname [lindex [set ::p::${OID}::o_$field] $stack]} |
||||
} |
||||
} |
||||
|
||||
#! what if someone has put a trace on ::errorInfo?? |
||||
set ::errorInfo $errorInfo_prev |
||||
|
||||
} |
||||
|
||||
trace add variable $refname {read} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::prop_trace_write $_ID_ $OID $alias $refname] |
||||
trace add variable $refname {write} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::prop_trace_unset $_ID_ $OID $alias $refname] |
||||
trace add variable $refname {unset} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::prop_trace_array $_ID_ $OID $alias $refname] |
||||
trace add variable $refname {array} $traceCmd |
||||
|
||||
} |
||||
|
||||
|
||||
} else { |
||||
#matching variable in order to detect attempted use as property and throw error |
||||
#puts "$refname ====> adding refMisuse_traceHandler $alias $field" |
||||
trace add variable $refname {read write unset} [list ::p::internals::commandrefMisuse_TraceHandler $alias $field] |
||||
} |
||||
} |
||||
|
||||
return $command |
||||
} |
||||
} |
||||
|
||||
|
||||
#script to inline at placeholder @reduce_pending_stack@ |
||||
set ::p::internals::reduce_pending_stack { |
||||
if {$pending eq {idx}} { |
||||
if {$OID ne {null}} { |
||||
#pattern object |
||||
#set command [list ::p::${OID}::$itemCmd [dict create i [dict create this [list $OID]]]] |
||||
set command ::p::${OID}::$itemCmd |
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map]]]]] |
||||
#todo: set _ID_ [dict create i [dict create this [list [list $OID - - - {}]]] context {}] |
||||
|
||||
} else { |
||||
set command [list $itemCmd $command] |
||||
} |
||||
} |
||||
if {![llength [info commands [lindex $command 0]]]} { |
||||
set cmdname [namespace tail [lindex $command 0]] |
||||
if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { |
||||
lset command 0 ::p::${OID}::(UNKNOWN) |
||||
#puts stdout "!\n calling UNKNOWN $command $cmdname $stack\n\n" |
||||
|
||||
if {[string length $_ID_]} { |
||||
set interim [uplevel 1 [list {*}$command $_ID_ $cmdname {*}$stack]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
set interim [uplevel 1 [list {*}$command $cmdname {*}$stack]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} |
||||
} else { |
||||
return -code error -errorinfo "1)error running command:'$command' argstack:'$stack'\n - command not found and no 'unknown' handler" "method '$command' not found" |
||||
} |
||||
} else { |
||||
#puts "---??? uplevelling $command $_ID_ $stack" |
||||
|
||||
if {[string length $_ID_]} { |
||||
set interim [uplevel 1 [list {*}$command $_ID_ {*}$stack]] |
||||
} else { |
||||
set interim [uplevel 1 [list {*}$command {*}$stack]] |
||||
} |
||||
#puts "---?2? interim:$interim" |
||||
} |
||||
|
||||
|
||||
|
||||
if {[string first ::> $interim] >= 0} { |
||||
#puts "--- ---> tailcalling $interim [lrange $args $i end]" |
||||
tailcall {*}$interim {*}[lrange $args $i end] ;#don't use a return statement as tailcall implies return |
||||
} else { |
||||
#the interim result is not a pattern object - but the . indicates we should treat it as a command |
||||
#tailcall ::p::internals::predator [list [list {null} {} {lindex} $interim {}]] {*}[lrange $args $i end] |
||||
#set nextmap [list [list {null} {} {lindex} $interim {}]] |
||||
#tailcall ::p::internals::predator [dict create i [dict create this [list null ]] map $nextmap] {*}[lrange $args $i end] |
||||
#tailcall ::p::internals::predator [dict create i [dict create this [list [list null [list]] ]] xmap $nextmap] {*}[lrange $args $i end] |
||||
|
||||
tailcall ::p::internals::predator [dict create i [dict create this [list [list null [list map [list [list {null} {} {lindex} $interim {}]]]] ]] callerinfo ""] {*}[lrange $args $i end] |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
proc ::p::predator1 {subject args} [string map [list @reduce_pending_stack@ $::p::internals::reduce_pending_stack] { |
||||
#set OID [lindex [dict get $subject i this] 0 0] |
||||
|
||||
set this_invocant [lindex [dict get $subject i this] 0] ;#for the role 'this' we assume only one invocant in the list. |
||||
lassign $this_invocant OID this_info |
||||
|
||||
if {$OID ne {null}} { |
||||
#upvar #0 ::p::${OID}::_meta::map map |
||||
#if {![dict exists [lindex [dict get $subject i this] 0 1] map]} { |
||||
# set map [set ::p::${OID}::_meta::map] |
||||
#} else { |
||||
# set map [dict get [lindex [dict get $subject i this] 0 1] map] |
||||
#} |
||||
#seems to be faster just to grab from the variable, than to unwrap from $_ID_ !? |
||||
#set map [set ::p::${OID}::_meta::map] |
||||
|
||||
|
||||
|
||||
# if {![dict exists $this_info map]} { |
||||
set map [set ::p::${OID}::_meta::map] |
||||
#} else { |
||||
# set map [dict get $this_info map] |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
lassign [lindex $map 0] OID alias itemCmd cmd |
||||
|
||||
set cheat 1 |
||||
#------- |
||||
#the common optimised case first. 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 {([llength $args] > 1) && ([lindex $args 0] eq {.}) && ([llength [lsearch -all $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args)} { |
||||
set command ::p::${OID}::[lindex $args 1] |
||||
|
||||
if {![llength [info commands $command]]} { |
||||
if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { |
||||
set cmdname [namespace tail $command] |
||||
lset command 0 ::p::${OID}::(UNKNOWN) |
||||
#return [uplevel 1 [list {*}$command [dict create i [dict create this [list [list $OID [list map $map]]]]] $cmdname {*}[lrange $args 2 end]]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
tailcall {*}$command [dict create i [dict create this [list [list $OID [list map [list [lindex $map 0] {{} {}} ] ] ]]]] $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
return -code error -errorinfo "2)error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$command' not found" |
||||
} |
||||
} else { |
||||
#puts " -->> tailcalling $command [lrange $args 2 end]" |
||||
#tailcall $command [dict create i [dict create this [list [list $OID [list map $map]] ]]] {*}[lrange $args 2 end] |
||||
#tailcall $command [dict create i [dict create this [list [list $OID {}] ]]] {*}[lrange $args 2 end] |
||||
|
||||
#jjj |
||||
#tailcall $command [list i [list this [list [list $OID [list map $map]] ]]] {*}[lrange $args 2 end] |
||||
tailcall $command [list i [list this [list [list $OID [list map [list [lindex $map 0] { {} {} } ]]] ]]] {*}[lrange $args 2 end] |
||||
} |
||||
} |
||||
} |
||||
#------------ |
||||
|
||||
|
||||
if {![llength $args]} { |
||||
#return $map |
||||
return [lindex $map 0 1] |
||||
} elseif {[llength $args] == 1} { |
||||
#short-circuit the single index case for speed. |
||||
if {$args ni {.. . -- - & @}} { |
||||
if {$cheat} { |
||||
|
||||
lassign [lindex $map 0] OID alias itemCmd |
||||
#return [::p::${OID}::$itemCmd [lindex $args 0]] |
||||
#tailcall ::p::${OID}::$itemCmd [dict create i [dict create this [list [list $OID [list map $map]]]]] [lindex $args 0] |
||||
tailcall ::p::${OID}::$itemCmd [list i [list this [list [list $OID [list map $map]]]]] [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 $map |
||||
} |
||||
} |
||||
} else { |
||||
#null OID - assume map is included in the _ID_ dict. |
||||
#set map [dict get $subject map] |
||||
set map [dict get $this_info map] |
||||
|
||||
lassign [lindex $map 0] OID alias itemCmd cmd |
||||
} |
||||
#puts "predator==== subject:$subject args:$args map:$map cmd:$cmd " |
||||
|
||||
|
||||
|
||||
#set map $invocant ;#retain 'invocant' in case we need original caller info.. 'map' is the data for whatever is at base of stack. |
||||
set command $cmd |
||||
set stack [list] |
||||
|
||||
#set operators [list . , ..] ;#(exclude --) |
||||
|
||||
|
||||
#!todo? short-circuit/inline commonest/simplest case {llength $args == 2} |
||||
|
||||
|
||||
set argProtect 0 |
||||
set pending "" ;#pending operator e.g . , idx .. & @ |
||||
set _ID_ "" |
||||
|
||||
set i 0 |
||||
|
||||
while {$i < [llength $args]} { |
||||
set word [lindex $args $i] |
||||
|
||||
if {$argProtect} { |
||||
#argProtect must be checked first. |
||||
# We are here because a previous operator necessitates that this word is an argument, not another operator. |
||||
set argProtect 0 |
||||
lappend stack $word |
||||
if {$pending eq {}} { |
||||
set pending idx ;#An argument only implies the index operator if no existing operator is in effect. (because '>obj $arg' must be equivalent to '>obj . item $arg' |
||||
} |
||||
incr i |
||||
} else { |
||||
switch -- $word {.} { |
||||
#$i is the operator, $i + 1 is the command. |
||||
if {[llength $args] > ($i + 1)} { |
||||
#there is at least a command, possibly args too |
||||
|
||||
if {$pending ne {}} { |
||||
#puts ">>>> >>>>> about to reduce. pending:$pending command:$command _ID_:$_ID_ stack:$stack" |
||||
|
||||
|
||||
#always bounces back into the predator via tailcall |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
if {$OID ne {null}} { |
||||
#set command ::p::${OID}::[lindex $args $i+1] |
||||
#lappend stack [dict create i [dict create this [list $OID]]] |
||||
|
||||
set command ::p::${OID}::[lindex $args $i+1] |
||||
set _ID_ [list i [list this [list [list $OID [list map $map]]]]] |
||||
|
||||
} else { |
||||
#set command [list $command [lindex $args $i+1]] |
||||
lappend stack [lindex $args $i+1] |
||||
} |
||||
set pending . |
||||
set argProtect 0 |
||||
incr i 2 |
||||
} |
||||
} else { |
||||
#this is a trailing . |
||||
#puts "----> MAP $map ,command $command ,stack $stack" |
||||
if {$OID ne {null}} { |
||||
return [::p::internals::trailing. $map $command $_ID_ $stack $i $args $pending] |
||||
} else { |
||||
#!todo - fix. This is broken! |
||||
#the usefulness of a reference to an already-resolved value is questionable.. but for consistency it should probably be made to work. |
||||
|
||||
#for a null object - we need to supply the map in the invocation data |
||||
set command ::p::internals::predator |
||||
|
||||
set this_info [dict create map [list [list {null} {} {lindex} $command {}]] ] |
||||
set this_invocant [list null $this_info] |
||||
|
||||
set _ID_ [dict create i [dict create this [list $this_invocant]] ] |
||||
|
||||
return [::p::internals::trailing. $map $command $_ID_ $stack $i $args $pending] |
||||
} |
||||
} |
||||
} {--} { |
||||
#argSafety operator (see also "," & -* below) |
||||
set argProtect 1 |
||||
incr i |
||||
} {,} { |
||||
set argProtect 1 |
||||
if {$i+1 < [llength $args]} { |
||||
#not trailing |
||||
if {$pending ne {}} { |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
if {$OID ne {null}} { |
||||
#set command [list ::p::[lindex $map 0 0]::$itemCmd [lindex $args $i+1]] |
||||
#set command [list $command . $itemCmd [lindex $args $i+1]] |
||||
|
||||
set stack [list . $itemCmd [lindex $args $i+1]] |
||||
|
||||
set _ID_ "" |
||||
|
||||
#lappend stack [dict create i [dict create this [list $OID]]] |
||||
|
||||
set pending "." |
||||
} else { |
||||
# this is an index operation into what is presumed to be a previously returned standard tcl list. (as opposed to an index operation into a returned pattern object) |
||||
#set command [list $itemCmd $command [lindex $args $i+1]] |
||||
#set command [list ::p::internals::predator [list [list {null} {} {lindex} $command {}]] [lindex $args $i+1] ] |
||||
|
||||
|
||||
#set command ::p::internals::predator |
||||
#set _ID_ [dict create i [dict create this [list null]] map [list [list {null} {} {lindex} [lindex $args $i+1] {}]] ] |
||||
#lappend stack [lindex $args $i+1] |
||||
|
||||
|
||||
set command [list $itemCmd $command] ;#e.g {lindex {a b c}} |
||||
|
||||
#set command ::p::internals::predator |
||||
#set _ID_ [dict create i [dict create this [list null]] map [list [list {null} {} {lindex} $nextcommand {}]]] |
||||
set _ID_ {} |
||||
lappend stack [lindex $args $i+1] |
||||
|
||||
|
||||
set pending "." ;#*not* idx or "," |
||||
} |
||||
|
||||
set argProtect 0 |
||||
incr i 2 |
||||
} |
||||
} else { |
||||
return [::p::internals::trailing, $map $command $stack $i $args $pending] |
||||
} |
||||
} {..} { |
||||
#Metaface operator |
||||
if {$i+1 < [llength $args]} { |
||||
#operator is not trailing. |
||||
if {$pending ne {}} { |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
incr i |
||||
|
||||
#set command [list ::p::-1::[lindex $args $i] [dict create i [dict create this [list $OID]]]] |
||||
set command ::p::-1::[lindex $args $i] |
||||
|
||||
#_ID_ is a list, 1st element being a dict of invocants. |
||||
# Each key of the dict is an invocant 'role' |
||||
# Each value is a list of invocant-aliases fulfilling that role |
||||
#lappend stack [list [list caller [lindex $map 0 1] ]] |
||||
#lappend stack [list [dict create this [lindex $map 0 1]]] ;#'this' being the 'subject' in a standard singledispatch method call. |
||||
#lappend stack [dict create i [dict create this [list [lindex $map 0 1]]]] |
||||
|
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map]]]]] |
||||
|
||||
set pending .. |
||||
incr i |
||||
} |
||||
} else { |
||||
return [::p::internals::trailing.. $map $command $stack $i $args $pending] |
||||
} |
||||
} {&} { |
||||
#conglomeration operator |
||||
if {$i+1 < [llength $args]} { |
||||
if {$pending ne {} } { |
||||
@reduce_pending_stack@ |
||||
|
||||
#set interim [uplevel 1 [list {*}$command {*}$stack]] |
||||
#tailcall {*}$interim {*}[lrange $args $i end] ;#don't use a return statement as tailcall implies return |
||||
} |
||||
|
||||
set command [list ::p::-1::Conglomerate $command] |
||||
lappend stack [lindex $args $i+1] |
||||
set pending & |
||||
incr i |
||||
|
||||
|
||||
|
||||
} else { |
||||
error "trailing & not supported" |
||||
} |
||||
} {@} { |
||||
#named-invocant operator |
||||
if {$i+1 < [llength $args]} { |
||||
if {$pending ne {} } { |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
error "@ not implemented" |
||||
|
||||
set pending @ |
||||
incr i |
||||
} |
||||
} else { |
||||
error "trailing @ not supported" |
||||
} |
||||
} default { |
||||
if {[string index $word 0] ni {. -}} { |
||||
lappend stack $word |
||||
if {$pending eq {}} { |
||||
set pending idx |
||||
} |
||||
incr i |
||||
} else { |
||||
if {[string match "-*" $word]} { |
||||
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||
set argProtect 1 |
||||
lappend stack $word |
||||
incr i |
||||
} else { |
||||
if {([string index $word 0] eq ".") && ([string index $word end] eq ".") } { |
||||
#interface accessor! |
||||
error "interface casts not yet implemented!" |
||||
|
||||
set ifspec [string range $word 1 end] |
||||
if {$ifspec eq "!"} { |
||||
#create 'snapshot' reference with all current interfaces |
||||
|
||||
} else { |
||||
foreach ifname [split $ifspec ,] { |
||||
#make each comma-separated interface-name accessible via the 'casted object' |
||||
|
||||
} |
||||
} |
||||
|
||||
} else { |
||||
#has a leading . only. treat as an argument not an operator. |
||||
lappend stack $word |
||||
if {$pending eq {}} { |
||||
set pending idx |
||||
} |
||||
incr i |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
} |
||||
|
||||
#assert: $pending ne "" |
||||
#(we've run out of args, and if no 'operators' were found, then $pending will have been set to 'idx' - equivalent to '. item' ) |
||||
|
||||
#puts "---> evalling command + stack:'$command' '$stack' (pending:'$pending')" |
||||
if {$pending in {idx}} { |
||||
if {$OID ne {null}} { |
||||
#pattern object |
||||
set command ::p::${OID}::$itemCmd |
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map] ] ]]] |
||||
} else { |
||||
# some other kind of command |
||||
set command [list $itemCmd $command] |
||||
} |
||||
} |
||||
if {![llength [info commands [lindex $command 0]]]} { |
||||
set cmdname [namespace tail [lindex $command 0]] |
||||
if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { |
||||
lset command 0 ::p::${OID}::(UNKNOWN) |
||||
#puts stdout "!\n calling UNKNOWN $command $cmdname $stack\n\n" |
||||
|
||||
if {[string length $_ID_]} { |
||||
tailcall {*}$command $_ID_ $cmdname {*}$stack ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
tailcall {*}$command $cmdname {*}$stack ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} |
||||
} else { |
||||
return -code error -errorinfo "3)error running command:'$command' argstack:'$stack'\n - command not found and no 'unknown' handler" "method '$command' not found" |
||||
} |
||||
} |
||||
#puts "... tailcalling $command $stack" |
||||
if {[string length $_ID_]} { |
||||
tailcall {*}$command $_ID_ {*}$stack |
||||
} else { |
||||
tailcall {*}$command {*}$stack |
||||
} |
||||
}] |
||||
@ -1,754 +0,0 @@
|
||||
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 |
||||
} |
||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
Binary file not shown.
@ -1,245 +0,0 @@
|
||||
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# UUIDs are 128 bit values that attempt to be unique in time and space. |
||||
# |
||||
# Reference: |
||||
# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt |
||||
# |
||||
# uuid: scheme: |
||||
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html |
||||
# |
||||
# Usage: uuid::uuid generate |
||||
# uuid::uuid equal $idA $idB |
||||
|
||||
package require Tcl 8.5 |
||||
|
||||
namespace eval uuid { |
||||
variable accel |
||||
array set accel {critcl 0} |
||||
|
||||
namespace export uuid |
||||
|
||||
variable uid |
||||
if {![info exists uid]} { |
||||
set uid 1 |
||||
} |
||||
|
||||
proc K {a b} {set a} |
||||
} |
||||
|
||||
### |
||||
# Optimization |
||||
# Caches machine info after the first pass |
||||
### |
||||
|
||||
proc ::uuid::generate_tcl_machinfo {} { |
||||
variable machinfo |
||||
if {[info exists machinfo]} { |
||||
return $machinfo |
||||
} |
||||
lappend machinfo [clock seconds]; # timestamp |
||||
lappend machinfo [clock clicks]; # system incrementing counter |
||||
lappend machinfo [info hostname]; # spatial unique id (poor) |
||||
lappend machinfo [pid]; # additional entropy |
||||
lappend machinfo [array get ::tcl_platform] |
||||
|
||||
### |
||||
# If we have /dev/urandom just stream 128 bits from that |
||||
### |
||||
if {[file exists /dev/urandom]} { |
||||
set fin [open /dev/urandom r] |
||||
binary scan [read $fin 128] H* machinfo |
||||
close $fin |
||||
} elseif {[catch {package require nettool}]} { |
||||
# More spatial information -- better than hostname. |
||||
# bug 1150714: opening a server socket may raise a warning messagebox |
||||
# with WinXP firewall, using ipconfig will return all IP addresses |
||||
# including ipv6 ones if available. ipconfig is OK on win98+ |
||||
if {[string equal $::tcl_platform(platform) "windows"]} { |
||||
catch {exec ipconfig} config |
||||
lappend machinfo $config |
||||
} else { |
||||
catch { |
||||
set s [socket -server void -myaddr [info hostname] 0] |
||||
K [fconfigure $s -sockname] [close $s] |
||||
} r |
||||
lappend machinfo $r |
||||
} |
||||
|
||||
if {[package provide Tk] != {}} { |
||||
lappend machinfo [winfo pointerxy .] |
||||
lappend machinfo [winfo id .] |
||||
} |
||||
} else { |
||||
### |
||||
# If the nettool package works on this platform |
||||
# use the stream of hardware ids from it |
||||
### |
||||
lappend machinfo {*}[::nettool::hwid_list] |
||||
} |
||||
return $machinfo |
||||
} |
||||
|
||||
# Generates a binary UUID as per the draft spec. We generate a pseudo-random |
||||
# type uuid (type 4). See section 3.4 |
||||
# |
||||
proc ::uuid::generate_tcl {} { |
||||
package require md5 2 |
||||
variable uid |
||||
|
||||
set tok [md5::MD5Init] |
||||
md5::MD5Update $tok [incr uid]; # package incrementing counter |
||||
foreach string [generate_tcl_machinfo] { |
||||
md5::MD5Update $tok $string |
||||
} |
||||
set r [md5::MD5Final $tok] |
||||
binary scan $r c* r |
||||
|
||||
# 3.4: set uuid versioning fields |
||||
lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] |
||||
lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] |
||||
|
||||
return [binary format c* $r] |
||||
} |
||||
|
||||
if {[string equal $tcl_platform(platform) "windows"] |
||||
&& [package provide critcl] != {}} { |
||||
namespace eval uuid { |
||||
critcl::ccode { |
||||
#define WIN32_LEAN_AND_MEAN |
||||
#define STRICT |
||||
#include <windows.h> |
||||
#include <ole2.h> |
||||
typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); |
||||
typedef const unsigned char cu_char; |
||||
} |
||||
critcl::cproc generate_c {Tcl_Interp* interp} ok { |
||||
HRESULT hr = S_OK; |
||||
int r = TCL_OK; |
||||
UUID uuid = {0}; |
||||
HMODULE hLib; |
||||
LPFNUUIDCREATE lpfnUuidCreate = NULL; |
||||
hLib = LoadLibraryA(("rpcrt4.dll")); |
||||
if (hLib) |
||||
lpfnUuidCreate = (LPFNUUIDCREATE) |
||||
GetProcAddress(hLib, "UuidCreate"); |
||||
if (lpfnUuidCreate) { |
||||
Tcl_Obj *obj; |
||||
lpfnUuidCreate(&uuid); |
||||
obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); |
||||
Tcl_SetObjResult(interp, obj); |
||||
} else { |
||||
Tcl_SetResult(interp, "error: failed to create a guid", |
||||
TCL_STATIC); |
||||
r = TCL_ERROR; |
||||
} |
||||
return r; |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Convert a binary uuid into its string representation. |
||||
# |
||||
proc ::uuid::tostring {uuid} { |
||||
binary scan $uuid H* s |
||||
foreach {a b} {0 7 8 11 12 15 16 19 20 end} { |
||||
append r [string range $s $a $b] - |
||||
} |
||||
return [string tolower [string trimright $r -]] |
||||
} |
||||
|
||||
# Convert a string representation of a uuid into its binary format. |
||||
# |
||||
proc ::uuid::fromstring {uuid} { |
||||
return [binary format H* [string map {- {}} $uuid]] |
||||
} |
||||
|
||||
# Compare two uuids for equality. |
||||
# |
||||
proc ::uuid::equal {left right} { |
||||
set l [fromstring $left] |
||||
set r [fromstring $right] |
||||
return [string equal $l $r] |
||||
} |
||||
|
||||
# Call our generate uuid implementation |
||||
proc ::uuid::generate {} { |
||||
variable accel |
||||
if {$accel(critcl)} { |
||||
return [generate_c] |
||||
} else { |
||||
return [generate_tcl] |
||||
} |
||||
} |
||||
|
||||
# uuid generate -> string rep of a new uuid |
||||
# uuid equal uuid1 uuid2 |
||||
# |
||||
proc uuid::uuid {cmd args} { |
||||
switch -exact -- $cmd { |
||||
generate { |
||||
if {[llength $args] != 0} { |
||||
return -code error "wrong # args:\ |
||||
should be \"uuid generate\"" |
||||
} |
||||
return [tostring [generate]] |
||||
} |
||||
equal { |
||||
if {[llength $args] != 2} { |
||||
return -code error "wrong \# args:\ |
||||
should be \"uuid equal uuid1 uuid2\"" |
||||
} |
||||
return [eval [linsert $args 0 equal]] |
||||
} |
||||
default { |
||||
return -code error "bad option \"$cmd\":\ |
||||
must be generate or equal" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# LoadAccelerator -- |
||||
# |
||||
# This package can make use of a number of compiled extensions to |
||||
# accelerate the digest computation. This procedure manages the |
||||
# use of these extensions within the package. During normal usage |
||||
# this should not be called, but the test package manipulates the |
||||
# list of enabled accelerators. |
||||
# |
||||
proc ::uuid::LoadAccelerator {name} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $name { |
||||
critcl { |
||||
if {![catch {package require tcllibc}]} { |
||||
set r [expr {[info commands ::uuid::generate_c] != {}}] |
||||
} |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator package:\ |
||||
must be one of [join [array names accel] {, }]" |
||||
} |
||||
} |
||||
set accel($name) $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Try and load a compiled extension to help. |
||||
namespace eval ::uuid { |
||||
variable e {} |
||||
foreach e {critcl} { |
||||
if {[LoadAccelerator $e]} break |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
package provide uuid 1.0.7 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
Binary file not shown.
Binary file not shown.
Loading…
Reference in new issue