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