Browse Source

update bootsupport and project_layotus

master
Julian Noble 12 hours ago
parent
commit
b152ea9775
  1. 3
      src/bootsupport/modules/include_modules.config
  2. 5989
      src/bootsupport/modules/metaface-1.2.8.tm
  3. 1459
      src/bootsupport/modules/patterncipher-0.1.1.tm
  4. 639
      src/bootsupport/modules/patterncmd-1.2.8.tm
  5. 2588
      src/bootsupport/modules/patternlib-1.2.8.tm
  6. 755
      src/bootsupport/modules/patternpredator2-1.2.8.tm
  7. 4
      src/bootsupport/modules/punk-0.1.tm
  8. 4
      src/bootsupport/modules/punk/aliascore-0.1.0.tm
  9. 19
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  10. 4
      src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm
  11. 194
      src/bootsupport/modules/punk/args-0.2.tm
  12. 7031
      src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm
  13. 195
      src/bootsupport/modules/punk/args/tclcore-0.1.0.tm
  14. 123
      src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
  15. 143
      src/bootsupport/modules/punk/lib-0.1.2.tm
  16. 4
      src/bootsupport/modules/punk/libunknown-0.1.tm
  17. 5
      src/bootsupport/modules/punk/mix-0.2.tm
  18. 14
      src/bootsupport/modules/punk/mix/cli-0.3.1.tm
  19. BIN
      src/bootsupport/modules/punk/mix/templates-0.1.2.tm
  20. 3414
      src/bootsupport/modules/punk/ns-0.1.0.tm
  21. 2
      src/bootsupport/modules/punk/packagepreference-0.1.0.tm
  22. 54
      src/bootsupport/modules/punk/pipe-1.0.tm
  23. 25
      src/bootsupport/modules/punk/repl-0.1.2.tm
  24. 1
      src/bootsupport/modules/textblock-0.1.3.tm
  25. 161
      src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm
  26. 12
      src/project_layouts/custom/_project/punk.basic/src/make.tcl
  27. 3
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config
  28. 5989
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.8.tm
  29. 1459
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncipher-0.1.1.tm
  30. 639
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncmd-1.2.8.tm
  31. 2588
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternlib-1.2.8.tm
  32. 755
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternpredator2-1.2.8.tm
  33. 4
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm
  34. 4
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm
  35. 19
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  36. 4
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm
  37. 194
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm
  38. 7031
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm
  39. 195
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm
  40. 123
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
  41. 143
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm
  42. 4
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm
  43. 5
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix-0.2.tm
  44. 14
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
  45. BIN
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.2.tm
  46. 3414
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  47. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
  48. 54
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/pipe-1.0.tm
  49. 25
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm
  50. 1
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  51. 12
      src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl
  52. 3
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config
  53. 5989
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/metaface-1.2.8.tm
  54. 1459
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncipher-0.1.1.tm
  55. 639
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncmd-1.2.8.tm
  56. 2588
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patternlib-1.2.8.tm
  57. 755
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patternpredator2-1.2.8.tm
  58. 4
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm
  59. 4
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm
  60. 19
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  61. 4
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm
  62. 194
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm
  63. 7031
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm
  64. 195
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm
  65. 123
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
  66. 143
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm
  67. 4
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm
  68. 5
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix-0.2.tm
  69. 14
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
  70. BIN
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/templates-0.1.2.tm
  71. 3414
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  72. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
  73. 54
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/pipe-1.0.tm
  74. 25
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm
  75. 1
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  76. 12
      src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl

3
src/bootsupport/modules/include_modules.config

@ -23,6 +23,7 @@ set bootsupport_modules [list\
src/vendormodules patterncmd\
src/vendormodules patternlib\
src/vendormodules patternpredator2\
src/vendormodules patterncipher\
src/vendormodules promise\
src/vendormodules sha1\
src/vendormodules tomlish\
@ -50,7 +51,7 @@ set bootsupport_modules [list\
modules punk::ansi\
modules punk::assertion\
modules punk::args\
modules punk::args::tclcore\
modules punk::args::moduledoc::tclcore\
modules punk::cap\
modules punk::cap::handlers::caphandler\
modules punk::cap::handlers::scriptlibs\

5989
src/bootsupport/modules/metaface-1.2.8.tm

File diff suppressed because it is too large Load Diff

1459
src/bootsupport/modules/patterncipher-0.1.1.tm

File diff suppressed because it is too large Load Diff

639
src/bootsupport/modules/patterncmd-1.2.8.tm

@ -0,0 +1,639 @@
package provide patterncmd [namespace eval patterncmd {
variable version
set version 1.2.8
}]
namespace eval pattern {
variable idCounter 1 ;#used by pattern::uniqueKey
namespace eval cmd {
namespace eval util {
package require overtype
variable colwidths_lib [dict create]
variable colwidths_lib_default 15
dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""]
dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""]
dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""]
dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"]
proc colhead {type args} {
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
set line ""
foreach colname [dict keys $colwidths] {
append line "[col $type $colname [string totitle $colname] {*}$args]"
}
return $line
}
proc colbreak {type} {
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
set line ""
foreach colname [dict keys $colwidths] {
append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]"
}
return $line
}
proc col {type col val args} {
# args -head bool -tail bool ?
#----------------------------------------------------------------------------
set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify]
dict set default -backchar ""
dict set default -headchar ""
dict set default -tailchar ""
dict set default -headoverridechar ""
dict set default -tailoverridechar ""
dict set default -justify "left"
if {([llength $args] % 2) != 0} {
error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' "
}
foreach {k v} $args {
if {$k ni $known_opts} {
error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'"
}
}
set opts [dict merge $default $args]
set backchar [dict get $opts -backchar]
set headchar [dict get $opts -headchar]
set tailchar [dict get $opts -tailchar]
set headoverridechar [dict get $opts -headoverridechar]
set tailoverridechar [dict get $opts -tailoverridechar]
set justify [dict get $opts -justify]
#----------------------------------------------------------------------------
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
#calculate headwidths
set headwidth 0
set tailwidth 0
foreach {key def} $colwidths {
set thisheadlen [string length [dict get $def head]]
if {$thisheadlen > $headwidth} {
set headwidth $thisheadlen
}
set thistaillen [string length [dict get $def tail]]
if {$thistaillen > $tailwidth} {
set tailwidth $thistaillen
}
}
set spec [dict get $colwidths $col]
if {[string length $backchar]} {
set ch $backchar
} else {
set ch [dict get $spec ch]
}
set num [dict get $spec num]
set headchar [dict get $spec head]
set tailchar [dict get $spec tail]
if {[string length $headchar]} {
set headchar $headchar
}
if {[string length $tailchar]} {
set tailchar $tailchar
}
#overrides only apply if the head/tail has a length
if {[string length $headchar]} {
if {[string length $headoverridechar]} {
set headchar $headoverridechar
}
}
if {[string length $tailchar]} {
if {[string length $tailoverridechar]} {
set tailchar $tailoverridechar
}
}
set head [string repeat $headchar $headwidth]
set tail [string repeat $tailchar $tailwidth]
set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]]
if {$justify eq "left"} {
set left_done [overtype::left $base "$head$val"]
return [overtype::right $left_done "$tail"]
} elseif {$justify in {centre center}} {
set mid_done [overtype::centre $base $val]
set left_mid_done [overtype::left $mid_done $head]
return [overtype::right $left_mid_done $tail]
} else {
set right_done [overtype::right $base "$val$tail"]
return [overtype::left $right_done $head]
}
}
}
}
}
#package require pattern
proc ::pattern::libs {} {
set libs [list \
pattern {-type core -note "alternative:pattern2"}\
pattern2 {-type core -note "alternative:pattern"}\
patterncmd {-type core}\
metaface {-type core}\
patternpredator2 {-type core}\
patterndispatcher {-type core}\
patternlib {-type core}\
patterncipher {-type optional -note optional}\
]
package require overtype
set result ""
append result "[cmd::util::colbreak lib]\n"
append result "[cmd::util::colhead lib -justify centre]\n"
append result "[cmd::util::colbreak lib]\n"
foreach libname [dict keys $libs] {
set libinfo [dict get $libs $libname]
append result [cmd::util::col lib library $libname]
if {[catch [list package present $libname] ver]} {
append result [cmd::util::col lib version "N/A"]
} else {
append result [cmd::util::col lib version $ver]
}
append result [cmd::util::col lib type [dict get $libinfo -type]]
if {[dict exists $libinfo -note]} {
set note [dict get $libinfo -note]
} else {
set note ""
}
append result [cmd::util::col lib note $note]
append result "\n"
}
append result "[cmd::util::colbreak lib]\n"
return $result
}
proc ::pattern::record {recname fields} {
if {[uplevel 1 [list namespace which $recname]] ne ""} {
error "(pattern::record) Can't create command '$recname': A command of that name already exists"
}
set index -1
set accessor [list ::apply {
{index rec args}
{
if {[llength $args] == 0} {
return [lindex $rec $index]
}
if {[llength $args] == 1} {
return [lreplace $rec $index $index [lindex $args 0]]
}
error "Invalid number of arguments."
}
}]
set map {}
foreach field $fields {
dict set map $field [linsert $accessor end [incr index]]
}
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec]
}
proc ::pattern::record2 {recname fields} {
if {[uplevel 1 [list namespace which $recname]] ne ""} {
error "(pattern::record) Can't create command '$recname': A command of that name already exists"
}
set index -1
set accessor [list ::apply]
set template {
{rec args}
{
if {[llength $args] == 0} {
return [lindex $rec %idx%]
}
if {[llength $args] == 1} {
return [lreplace $rec %idx% %idx% [lindex $args 0]]
}
error "Invalid number of arguments."
}
}
set map {}
foreach field $fields {
set body [string map [list %idx% [incr index]] $template]
dict set map $field [list ::apply $body]
}
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec]
}
proc ::argstest {args} {
package require cmdline
}
proc ::pattern::objects {} {
set result [::list]
foreach ns [namespace children ::pp] {
#lappend result [::list [namespace tail $ns] [set ${ns}::(self)]]
set ch [namespace tail $ns]
if {[string range $ch 0 2] eq "Obj"} {
set OID [string range $ch 3 end] ;#OID need not be digits (!?)
lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]]
}
}
return $result
}
proc ::pattern::name {num} {
#!todo - fix
#set ::p::${num}::(self)
lassign [interp alias {} ::p::$num] _predator info
if {![string length $_predator$info]} {
error "No object found for num:$num (no interp alias for ::p::$num)"
}
set invocants [dict get $info i]
set invocants_with_role_this [dict get $invocants this]
set invocant_this [lindex $invocants_with_role_this 0]
#lassign $invocant_this id info
#set map [dict get $info map]
#set fields [lindex $map 0]
lassign $invocant_this _id _ns _defaultmethod name _etc
return $name
}
proc ::pattern::with {cmd script} {
foreach c [info commands ::p::-1::*] {
interp alias {} [namespace tail $c] {} $c $cmd
}
interp alias {} . {} $cmd .
interp alias {} .. {} $cmd ..
return [uplevel 1 $script]
}
#system diagnostics etc
proc ::pattern::varspace_list {IID} {
namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables
set varspaces [list]
dict for {vname vdef} $o_variables {
set vs [dict get $vdef varspace]
if {$vs ni $varspaces} {
lappend varspaces $vs
}
}
if {$o_varspace ni $varspaces} {
lappend varspaces $o_varspace
}
return $varspaces
}
proc ::pattern::check_interfaces {} {
foreach ns [namespace children ::p] {
set IID [namespace tail $ns]
if {[string is digit $IID]} {
foreach ref [array names ${ns}::_iface::o_usedby] {
set OID [string range $ref 1 end]
if {![namespace exists ::p::${OID}::_iface]} {
puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n"
} else {
puts -nonewline stdout .
}
#if {![info exists ::p::${OID}::(self)]} {
# puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID"
#}
}
}
}
puts -nonewline stdout "\r\n"
}
#from: http://wiki.tcl.tk/8766 (Introspection on aliases)
#usedby: metaface-1.1.6+
#required because aliases can be renamed.
#A renamed alias will still return it's target with 'interp alias {} oldname'
# - so given newname - we require which_alias to return the same info.
proc ::pattern::which_alias {cmd} {
uplevel 1 [list ::trace add execution $cmd enterstep ::error]
catch {uplevel 1 $cmd} res
uplevel 1 [list ::trace remove execution $cmd enterstep ::error]
#puts stdout "which_alias $cmd returning '$res'"
return $res
}
# [info args] like proc following an alias recursivly until it reaches
# the proc it originates from or cannot determine it.
# accounts for default parameters set by interp alias
#
proc ::pattern::aliasargs {cmd} {
set orig $cmd
set defaultargs [list]
# loop until error or return occurs
while {1} {
# is it a proc already?
if {[string equal [info procs $cmd] $cmd]} {
set result [info args $cmd]
# strip off the interp set default args
return [lrange $result [llength $defaultargs] end]
}
# is it a built in or extension command we can get no args for?
if {![string equal [info commands $cmd] $cmd]} {
error "\"$orig\" isn't a procedure"
}
# catch bogus cmd names
if {[lsearch [interp aliases {}] $cmd]==-1} {
if {[catch {::pattern::which_alias $cmd} alias]} {
error "\"$orig\" isn't a procedure or alias or command"
}
#set cmd [lindex $alias 0]
if {[llength $alias]>1} {
set cmd [lindex $alias 0]
set defaultargs [concat [lrange $alias 1 end] $defaultargs]
} else {
set cmd $alias
}
} else {
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} {
# check if it is aliased in from another interpreter
if {[catch {interp target {} $cmd} msg]} {
error "Cannot resolve \"$orig\", alias leads to another interpreter."
}
if {$msg != {} } {
error "Not recursing into slave interpreter \"$msg\".\
\"$orig\" could not be resolved."
}
# check if defaults are set for the alias
if {[llength $cmdargs]>1} {
set cmd [lindex $cmdargs 0]
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs]
} else {
set cmd $cmdargs
}
}
}
}
}
proc ::pattern::aliasbody {cmd} {
set orig $cmd
set defaultargs [list]
# loop until error or return occurs
while {1} {
# is it a proc already?
if {[string equal [info procs $cmd] $cmd]} {
set result [info body $cmd]
# strip off the interp set default args
return $result
#return [lrange $result [llength $defaultargs] end]
}
# is it a built in or extension command we can get no args for?
if {![string equal [info commands $cmd] $cmd]} {
error "\"$orig\" isn't a procedure"
}
# catch bogus cmd names
if {[lsearch [interp aliases {}] $cmd]==-1} {
if {[catch {::pattern::which_alias $cmd} alias]} {
error "\"$orig\" isn't a procedure or alias or command"
}
#set cmd [lindex $alias 0]
if {[llength $alias]>1} {
set cmd [lindex $alias 0]
set defaultargs [concat [lrange $alias 1 end] $defaultargs]
} else {
set cmd $alias
}
} else {
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} {
# check if it is aliased in from another interpreter
if {[catch {interp target {} $cmd} msg]} {
error "Cannot resolve \"$orig\", alias leads to another interpreter."
}
if {$msg != {} } {
error "Not recursing into slave interpreter \"$msg\".\
\"$orig\" could not be resolved."
}
# check if defaults are set for the alias
if {[llength $cmdargs]>1} {
set cmd [lindex $cmdargs 0]
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs]
} else {
set cmd $cmdargs
}
}
}
}
}
proc ::pattern::uniqueKey2 {} {
#!todo - something else??
return [clock seconds]-[incr ::pattern::idCounter]
}
#used by patternlib package
proc ::pattern::uniqueKey {} {
return [incr ::pattern::idCounter]
#uuid with tcllibc is about 30us compared with 2us
# for large datasets, e.g about 100K inserts this would be pretty noticable!
#!todo - uuid pool with background thread to repopulate when idle?
#return [uuid::uuid generate]
}
#-------------------------------------------------------------------------------------------------------------------------
proc ::pattern::test1 {} {
set msg "OK"
puts stderr "next line should say:'--- saystuff:$msg"
::>pattern .. Create ::>thing
::>thing .. PatternMethod saystuff args {
puts stderr "--- saystuff: $args"
}
::>thing .. Create ::>jjj
::>jjj . saystuff $msg
::>jjj .. Destroy
::>thing .. Destroy
}
proc ::pattern::test2 {} {
set msg "OK"
puts stderr "next line should say:'--- property 'stuff' value:$msg"
::>pattern .. Create ::>thing
::>thing .. PatternProperty stuff $msg
::>thing .. Create ::>jjj
puts stderr "--- property 'stuff' value:[::>jjj . stuff]"
::>jjj .. Destroy
::>thing .. Destroy
}
proc ::pattern::test3 {} {
set msg "OK"
puts stderr "next line should say:'--- property 'stuff' value:$msg"
::>pattern .. Create ::>thing
::>thing .. Property stuff $msg
puts stderr "--- property 'stuff' value:[::>thing . stuff]"
::>thing .. Destroy
}
#---------------------------------
#unknown/obsolete
#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args}
if {0} {
proc ::p::internals::new_interface {{usedbylist {}}} {
set OID [incr ::p::ID]
::p::internals::new_object ::p::ifaces::>$OID "" $OID
puts "obsolete >> new_interface created object $OID"
foreach usedby $usedbylist {
set ::p::${OID}::_iface::o_usedby(i$usedby) 1
}
set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace)
#NOTE - o_varspace is only the default varspace for when new methods/properties are added.
# it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value.
set ::p::${OID}::_iface::o_constructor [list]
set ::p::${OID}::_iface::o_variables [list]
set ::p::${OID}::_iface::o_properties [dict create]
set ::p::${OID}::_iface::o_methods [dict create]
array set ::p::${OID}::_iface::o_definition [list]
set ::p::${OID}::_iface::o_open 1 ;#open for extending
return $OID
}
#temporary way to get OID - assumes single 'this' invocant
#!todo - make generic.
proc ::pattern::get_oid {_ID_} {
#puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]"
return [lindex [dict get $_ID_ i this] 0 0]
#set invocants [dict get $_ID_ i]
#set invocant_roles [dict keys $invocants]
#set role_members [dict get $invocants this]
##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list.
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;
#lassign $this_invocant OID this_info
#
#return $OID
}
#compile the uncompiled level1 interface
#assert: no more than one uncompiled interface present at level1
proc ::p::meta::PatternCompile {self} {
error "PatternCompile ????"
upvar #0 $self SELFMAP
set ID [lindex $SELFMAP 0 0]
set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces
set iid -1
foreach i $patterns {
if {[set ::p::${i}::_iface::o_open]} {
set iid $i ;#found it
break
}
}
if {$iid > -1} {
#!todo
::p::compile_interface $iid
set ::p::${iid}::_iface::o_open 0
} else {
#no uncompiled interface present at level 1. Do nothing.
return
}
}
proc ::p::meta::Def {self} {
error ::p::meta::Def
upvar #0 $self SELFMAP
set self_ID [lindex $SELFMAP 0 0]
set IFID [lindex $SELFMAP 1 0 end]
set maxc1 0
set maxc2 0
set arrName ::p::${IFID}::
upvar #0 $arrName state
array set methods {}
foreach nm [array names state] {
if {[regexp {^m-1,name,(.+)} $nm _match mname]} {
set methods($mname) [set state($nm)]
if {[string length $mname] > $maxc1} {
set maxc1 [string length $mname]
}
if {[string length [set state($nm)]] > $maxc2} {
set maxc2 [string length [set state($nm)]]
}
}
}
set bg1 [string repeat " " [expr {$maxc1 + 2}]]
set bg2 [string repeat " " [expr {$maxc2 + 2}]]
set r {}
foreach nm [lsort -dictionary [array names methods]] {
set arglist $state(m-1,args,$nm)
append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n"
}
return $r
}
}

2588
src/bootsupport/modules/patternlib-1.2.8.tm

File diff suppressed because it is too large Load Diff

755
src/bootsupport/modules/patternpredator2-1.2.8.tm

@ -0,0 +1,755 @@
proc ::p::internals::jaws {OID _ID_ args} {
#puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args"
#set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
yield
set w 1
set stack [list]
set wordcount [llength $args]
set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first
set unsupported 0
set operator ""
set operator_prev "" ;#used only by argprotect to revert to previous operator
if {$OID ne "null"} {
#!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!)
#upvar #0 ::p::${OID}::_meta::map MAP
set MAP [set ::p::${OID}::_meta::map]
} else {
# error "jaws - OID = 'null' ???"
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key
}
set invocantdata [dict get $MAP invocantdata]
lassign $invocantdata OID alias default_method object_command wrapped
set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code
#don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w
while {$w < $wordcount} {
set word [lindex $args [expr {$w -1}]]
#puts stdout "w:$w word:$word stack:$stack"
if {$operator eq "argprotect"} {
set operator $operator_prev
lappend stack $word
incr w
} else {
if {[llength $stack]} {
if {$word in $terminals} {
set reduction [list 0 $_ID_ {*}$stack ]
#puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w"
set _ID_ [yield $reduction]
set stack [list]
#set OID [::pattern::get_oid $_ID_]
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
if {$OID ne "null"} {
set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here!
} else {
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]]
#puts stderr "WARNING REVIEW: jaws-branch - leave empty??????"
}
#review - 2018. switched to _ID_ instead of MAP
lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command
#lassign [dict get $MAP invocantdata] OID alias default_method object_command
#puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command"
set operator $word
#don't incr w
#incr w
} else {
if {$operator eq "argprotect"} {
set operator $operator_prev
set operator_prev ""
lappend stack $word
} else {
#only look for leading argprotect chacter (-) if we're not already in argprotect mode
if {$word eq "--"} {
set operator_prev $operator
set operator "argprotect"
#Don't add the plain argprotector to the stack
} elseif {[string match "-*" $word]} {
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument)
set operator_prev $operator
set operator "argprotect"
lappend stack $word
} else {
lappend stack $word
}
}
incr w
}
} else {
#no stack
switch -- $word {.} {
if {$OID ne "null"} {
#we know next word is a property or method of a pattern object
incr w
set nextword [lindex $args [expr {$w - 1}]]
set command ::p::${OID}::$nextword
set stack [list $command] ;#2018 j
set operator .
if {$w eq $wordcount} {
set finished_args 1
}
} else {
# don't incr w
#set nextword [lindex $args [expr {$w - 1}]]
set command $object_command ;#taken from the MAP
set stack [list "_exec_" $command]
set operator .
}
} {..} {
incr w
set nextword [lindex $args [expr {$w -1}]]
set command ::p::-1::$nextword
#lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list.
set stack [list $command] ;#faster, and intent is clearer than lappend.
set operator ..
if {$w eq $wordcount} {
set finished_args 1
}
} {,} {
#puts stdout "Stackless comma!"
if {$OID ne "null"} {
set command ::p::${OID}::$default_method
} else {
set command [list $default_method $object_command]
#object_command in this instance presumably be a list and $default_method a list operation
#e.g "lindex {A B C}"
}
#lappend stack $command
set stack [list $command]
set operator ,
} {--} {
set operator_prev $operator
set operator argprotect
#no stack -
} {!} {
set command $object_command
set stack [list "_exec_" $object_command]
#puts stdout "!!!! !!!! $stack"
set operator !
} default {
if {$operator eq ""} {
if {$OID ne "null"} {
set command ::p::${OID}::$default_method
} else {
set command [list $default_method $object_command]
}
set stack [list $command]
set operator ,
lappend stack $word
} else {
#no stack - so we don't expect to be in argprotect mode already.
if {[string match "-*" $word]} {
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument)
set operator_prev $operator
set operator "argprotect"
lappend stack $word
} else {
lappend stack $word
}
}
}
incr w
}
}
} ;#end while
#process final word outside of loop
#assert $w == $wordcount
#trailing operators or last argument
if {!$finished_args} {
set word [lindex $args [expr {$w -1}]]
if {$operator eq "argprotect"} {
set operator $operator_prev
set operator_prev ""
lappend stack $word
incr w
} else {
switch -- $word {.} {
if {![llength $stack]} {
#set stack [list "_result_" [::p::internals::ref_to_object $_ID_]]
yieldto return [::p::internals::ref_to_object $_ID_]
error "assert: never gets here"
} else {
#puts stdout "==== $stack"
#assert - whenever _ID_ changed in this proc - we have updated the $OID variable
yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack]
error "assert: never gets here"
}
set operator .
} {..} {
#trailing .. after chained call e.g >x . item 0 ..
#puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$"
#set reduction [list 0 $_ID_ {*}$stack]
yieldto return [yield [list 0 $_ID_ {*}$stack]]
} {#} {
set unsupported 1
} {,} {
set unsupported 1
} {&} {
set unsupported 1
} {@} {
set unsupported 1
} {--} {
#set reduction [list 0 $_ID_ {*}$stack[set stack [list]]]
#puts stdout " -> -> -> about to call yield $reduction <- <- <-"
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ]
#set OID [::pattern::get_oid $_ID_]
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
if {$OID ne "null"} {
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here!
} else {
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ]
}
yieldto return $MAP
} {!} {
#error "untested branch"
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]]
#set OID [::pattern::get_oid $_ID_]
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
if {$OID ne "null"} {
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here!
} else {
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ]
}
lassign [dict get $MAP invocantdata] OID alias default_command object_command
set command $object_command
set stack [list "_exec_" $command]
set operator !
} default {
if {$operator eq ""} {
#error "untested branch"
lassign [dict get $MAP invocantdata] OID alias default_command object_command
#set command ::p::${OID}::item
set command ::p::${OID}::$default_command
lappend stack $command
set operator ,
}
#do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway.
lappend stack $word
}
if {$unsupported} {
set unsupported 0
error "trailing '$word' not supported"
}
#if {$operator eq ","} {
# incr wordcount 2
# set stack [linsert $stack end-1 . item]
#}
incr w
}
}
#final = 1
#puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]"
return [list 1 $_ID_ {*}$stack]
}
#trailing. directly after object
proc ::p::internals::ref_to_object {_ID_} {
set OID [lindex [dict get $_ID_ i this] 0 0]
upvar #0 ::p::${OID}::_meta::map MAP
lassign [dict get $MAP invocantdata] OID alias default_method object_command
set refname ::p::${OID}::_ref::__OBJECT
array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_]
if {[list {read} $traceCmd] ni [trace info variable $refname]} {
#puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'"
trace add variable $refname {read} $traceCmd
}
set traceCmd [list ::p::predator::object_array_trace $OID $_ID_]
if {[list {array} $traceCmd] ni [trace info variable $refname]} {
trace add variable $refname {array} $traceCmd
}
set traceCmd [list ::p::predator::object_write_trace $OID $_ID_]
if {[list {write} $traceCmd] ni [trace info variable $refname]} {
trace add variable $refname {write} $traceCmd
}
set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_]
if {[list {unset} $traceCmd] ni [trace info variable $refname]} {
trace add variable $refname {unset} $traceCmd
}
return $refname
}
proc ::p::internals::create_or_update_reference {OID _ID_ refname command} {
#if {[lindex $fullstack 0] eq "_exec_"} {
# #strip it. This instruction isn't relevant for a reference.
# set commandstack [lrange $fullstack 1 end]
#} else {
# set commandstack $fullstack
#}
#set argstack [lassign $commandstack command]
#set field [string map {> __OBJECT_} [namespace tail $command]]
set reftail [namespace tail $refname]
set argstack [lassign [split $reftail +] field]
set field [string map {> __OBJECT_} [namespace tail $command]]
#puts stderr "refname:'$refname' command: $command field:$field"
if {$OID ne "null"} {
upvar #0 ::p::${OID}::_meta::map MAP
} else {
#set map [dict get [lindex [dict get $_ID_ i this] 0 1] map]
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}]
}
lassign [dict get $MAP invocantdata] OID alias default_method object_command
if {$OID ne "null"} {
interp alias {} $refname {} $command $_ID_ {*}$argstack
} else {
interp alias {} $refname {} $command {*}$argstack
}
#set iflist [lindex $map 1 0]
set iflist [dict get $MAP interfaces level0]
#set iflist [dict get $MAP interfaces level0]
set field_is_property_like 0
foreach IFID [lreverse $iflist] {
#tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient.
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} {
set field_is_property_like 1
#There is a setter or getter (but not necessarily an entry in the o_properties dict)
break
}
}
#whether field is a property or a method - remove any commandrefMisuse_TraceHandler
foreach tinfo [trace info variable $refname] {
#puts "-->removing traces on $refname: $tinfo"
if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} {
trace remove variable $refname {*}$tinfo
}
}
if {$field_is_property_like} {
#property reference
set this_invocantdata [lindex [dict get $_ID_ i this] 0]
lassign $this_invocantdata OID _alias _defaultmethod object_command
#get fully qualified varspace
#
set propdict [$object_command .. GetPropertyInfo $field]
if {[dict exists $propdict $field]} {
set field_is_a_property 1
set propinfo [dict get $propdict $field]
set varspace [dict get $propinfo varspace]
if {$varspace eq ""} {
set full_varspace ::p::${OID}
} else {
if {[::string match "::*" $varspace]} {
set full_varspace $varspace
} else {
set full_varspace ::p::${OID}::$varspace
}
}
} else {
set field_is_a_property 0
#no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property
#this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later)
set full_varspace ::p::${OID}
}
#We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first))
set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field]
if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} {
trace add variable ${full_varspace}::o_${field} {write} $Hndlr
}
set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field]
if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} {
trace add variable ${full_varspace}::o_${field} {unset} $Hndlr
}
#supply all data in easy-access form so that propref_trace_read is not doing any extra work.
set get_cmd ::p::${OID}::(GET)$field
set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack]
if {[list {read} $traceCmd] ni [trace info variable $refname]} {
set fieldvarname ${full_varspace}::o_${field}
#synch the refvar with the real var if it exists
#catch {set $refname [$refname]}
if {[array exists $fieldvarname]} {
if {![llength $argstack]} {
#unindexed reference
array set $refname [array get $fieldvarname]
#upvar $fieldvarname $refname
} else {
set s0 [lindex $argstack 0]
#refs to nonexistant array members common? (catch vs 'info exists')
if {[info exists ${fieldvarname}($s0)]} {
set $refname [set ${fieldvarname}($s0)]
}
}
} else {
#refs to uninitialised props actually should be *very* common.
#If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive.
#Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch.
#set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches!
#puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------"
if {![llength $argstack]} {
#catch {set $refname [set ::p::${OID}::o_$field]}
if {[info exists $fieldvarname]} {
set $refname [set $fieldvarname]
#upvar $fieldvarname $refname
}
} else {
if {[llength $argstack] == 1} {
#catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]}
if {[info exists $fieldvarname]} {
set $refname [lindex [set $fieldvarname] [lindex $argstack 0]]
}
} else {
#catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]}
if {[info exists $fieldvarname]} {
set $refname [lindex [set $fieldvarname] $argstack]
}
}
}
#! what if someone has put a trace on ::errorInfo??
#set ::errorInfo $errorInfo_prev
}
trace add variable $refname {read} $traceCmd
set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname]
trace add variable $refname {write} $traceCmd
set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname]
trace add variable $refname {unset} $traceCmd
set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname]
# puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd"
trace add variable $refname {array} $traceCmd
}
} else {
#puts "$refname ====> adding refMisuse_traceHandler $alias $field"
#matching variable in order to detect attempted use as property and throw error
# 2018
#Note that we are adding a trace on a variable (the refname) which does not exist.
#this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex)
#we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added
##array set $refname {} ;#empty array
# - the empty array would mean a slightly better error message when misusing a command ref as an array
#but this seems like a code complication for little benefit
#review
trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field]
}
}
#trailing. after command/property
proc ::p::internals::ref_to_stack {OID _ID_ fullstack} {
if {[lindex $fullstack 0] eq "_exec_"} {
#strip it. This instruction isn't relevant for a reference.
set commandstack [lrange $fullstack 1 end]
} else {
set commandstack $fullstack
}
set argstack [lassign $commandstack command]
set field [string map {> __OBJECT_} [namespace tail $command]]
#!todo?
# - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace.
# - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted.
#references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself.
# - this would in theory allow a set of interface functions on the object which have direct access to the reference variables.
set refname ::p::${OID}::_ref::[join [concat $field $argstack] +]
if {[llength [info commands $refname]]} {
#todo - review - what if the field changed to/from a property/method?
#probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs
return $refname
}
::p::internals::create_or_update_reference $OID $_ID_ $refname $command
return $refname
}
namespace eval pp {
variable operators [list .. . -- - & @ # , !]
variable operators_notin_args ""
foreach op $operators {
append operators_notin_args "({$op} ni \$args) && "
}
set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands
#set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)}
}
interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks!
# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism.
#each map is a 2 element list of lists.
# form: {$commandinfo $interfaceinfo}
# commandinfo is of the form: {ID Namespace defaultmethod commandname _?}
#2018
#each map is a dict.
#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}}
#OID = Object ID (integer for now - could in future be a uuid)
proc ::p::predator2 {_ID_ args} {
#puts stderr "predator2: _ID_:'$_ID_' args:'$args'"
#set invocants [dict get $_ID_ i]
#set invocant_roles [dict keys $invocants]
#For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc.
#set this_role_members [dict get $invocants this]
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list.
#lassign $this_invocant this_OID this_info_dict
set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
set cheat 1 ;#
#-------
#Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call)
#(it should be functionally equivalent to remove this shortcut block)
if {$cheat} {
if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} {
set remaining_args [lassign $args dot method_or_prop]
#how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ???
set command ::p::${this_OID}::$method_or_prop
#REVIEW!
#e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say')
#if {[llength $command] > 1} {
# error "methods with spaces not included in test suites - todo fix!"
#}
#Dont use {*}$command - (so we can support methods with spaces)
#if {![llength [info commands $command]]} {}
if {[namespace which $command] eq ""} {
if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} {
#lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces
set command ::p::${this_OID}::(UNKNOWN)
#tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
} else {
return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found"
}
} else {
#tailcall {*}$command $_ID_ {*}$remaining_args
tailcall $command $_ID_ {*}$remaining_args
}
}
}
#------------
if {([llength $args] == 1) && ([lindex $args 0] eq "..")} {
return $_ID_
}
#puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args"
#puts stderr "this_info_dict: $this_info_dict"
if {![llength $args]} {
#should return some sort of public info.. i.e probably not the ID which is an implementation detail
#return cmd
return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID
#return a dict keyed on object command name - (suitable as use for a .. Create 'target')
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped
#return [list $object_command [list -id $this_OID ]]
} elseif {[llength $args] == 1} {
#short-circuit the single index case for speed.
if {[lindex $args 0] ni {.. . -- - & @ # , !}} {
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method
lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method
tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0]
} elseif {[lindex $args 0] eq {--}} {
#!todo - we could hide the invocant by only allowing this call from certain uplevel procs..
# - combined with using UUIDs for $OID, and a secured/removed metaface on the object
# - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases)
# - this could effectively hide the object's namespaces,vars etc from the caller (?)
return [set ::p::${this_OID}::_meta::map]
}
}
#upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls)
#incr c
#set reduce ::p::reducer${this_OID}_$c
set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance]
#puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args"
coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args
set current_ID_ $_ID_
set final 0
set result ""
while {$final == 0} {
#the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws)
set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command]
#puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'"
#if {[string match *Destroy $command]} {
# puts stdout " calling Destroy reduction_args:'$reduction_args'"
#}
if {$final == 1} {
if {[llength $command] == 1} {
if {$command eq "_exec_"} {
tailcall {*}$reduction_args
}
if {[llength [info commands $command]]} {
tailcall {*}$command $current_ID_ {*}$reduction_args
}
set cmdname [namespace tail $command]
set this_OID [lindex [dict get $current_ID_ i this] 0 0]
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} {
lset command 0 ::p::${this_OID}::(UNKNOWN)
tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg.
} else {
return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found"
}
} else {
#e.g lindex {a b c}
tailcall {*}$command {*}$reduction_args
}
} else {
if {[lindex $command 0] eq "_exec_"} {
set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]]
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ]
} else {
if {[llength $command] == 1} {
if {![llength [info commands $command]]} {
set cmdname [namespace tail $command]
set this_OID [lindex [dict get $current_ID_ i this] 0 0]
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} {
lset command 0 ::p::${this_OID}::(UNKNOWN)
set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
} else {
return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found"
}
} else {
#set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]]
set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]]
}
} else {
set result [uplevel 1 [list {*}$command {*}$reduction_args]]
}
if {[llength [info commands $result]]} {
if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} {
#looks like a pattern command
set current_ID_ [$result .. INVOCANTDATA]
#todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA
#if {![catch {$result .. INVOCANTDATA} result_invocantdata]} {
# set current_ID_ $result_invocantdata
#} else {
# return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object"
#}
} else {
#non-pattern command
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}]
}
} else {
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}]
#!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists)
}
}
}
}
error "Assert: Shouldn't get here (end of ::p::predator2)"
#return $result
}
package provide patternpredator2 1.2.8

4
src/bootsupport/modules/punk-0.1.tm

@ -8122,10 +8122,10 @@ namespace eval punk {
interp alias {} mode {} punk::mode
proc aliases {{glob *}} {
tailcall punk::lib::aliases $glob
tailcall punk::ns::aliases $glob
}
proc alias {{aliasorglob ""} args} {
tailcall punk::lib::alias $aliasorglob {*}$args
tailcall punk::ns::alias $aliasorglob {*}$args
}

4
src/bootsupport/modules/punk/aliascore-0.1.0.tm

@ -108,8 +108,6 @@ tcl::namespace::eval punk::aliascore {
# the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were.
set aliases [tcl::dict::create\
val ::punk::pipe::val\
aliases ::punk::lib::aliases\
alias ::punk::lib::alias\
tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\
@ -138,6 +136,8 @@ tcl::namespace::eval punk::aliascore {
config ::punk::config\
s ::punk::ns::synopsis\
eg ::punk::ns::eg\
aliases ::punk::ns::aliases\
alias ::punk::ns::alias\
]
#*** !doctools

19
src/bootsupport/modules/punk/ansi-0.1.1.tm

@ -147,14 +147,18 @@ tcl::namespace::eval punk::ansi::class {
}]
method render_to_input_line {args} {
if {[llength $args] < 1} {
puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args
#puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
#punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args
punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line"
return
}
set x [lindex $args end]
set arglist [lrange $args 0 end-1]
if {[llength $arglist] %2 != 0} {
puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args
#puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
#punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args
punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line"
return
}
set opts [tcl::dict::create\
-dimensions 80x24\
@ -6076,12 +6080,13 @@ tcl::namespace::eval punk::ansi::ta {
}
#perl: ta_strip
punk::args::set_alias ::punk::ansi::ta::strip ::punk::ansi::ansistrip
proc strip {text} {
#*** !doctools
#[call [fun strip] [arg text]]
#[para]Return text stripped of Ansi codes
#[para]This is a tailcall to punk::ansi::ansistrip
tailcall ansistrip $text
tailcall punk::ansi::ansistrip $text
}
lappend PUNKARGS [list {
@ -6113,7 +6118,7 @@ tcl::namespace::eval punk::ansi::ta {
"Calculate length of text (excluding the ANSI codes)
This is not the printing length of the string on screen."
@values -min 1
text -type string
text -type string
} ]
#perl: ta_length
proc length {text} {
@ -6133,7 +6138,7 @@ tcl::namespace::eval punk::ansi::ta {
#perl: ta_trunc
#truncate $text to $width columns while still including all the ANSI colour codes.
proc trunc {text width args} {
error "unimplemented"
}
#not in perl ta

4
src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm

@ -1,6 +1,6 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_::punk::ansi::colourmap 0 0.1.0]
#[manpage_begin punkshell_module_::punk::ansi::colourmap 0 0.1.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]

194
src/bootsupport/modules/punk/args-0.2.tm

@ -257,7 +257,7 @@ tcl::namespace::eval punk::args::register {
if {![info exists scanned_info]} {
set scanned_info [dict create]
}
#some packages, e.g punk::args::tclcore document other namespaces.
#some packages, e.g punk::args::moduledoc::tclcore document other namespaces.
#when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources
variable namespace_docpackages
if {![info exists namespace_docpackages]} {
@ -466,6 +466,8 @@ tcl::namespace::eval punk::args {
recognised types:
any
(unvalidated - accepts anything)
unknown
(unvalidated - accepts anything)
none
(used for flags/switches only. Indicates this is
a 'solo' flag ie accepts no value)
@ -475,6 +477,8 @@ tcl::namespace::eval punk::args {
number
list
indexexpression
indexset
(as accepted by punk::lib::is_indexset)
dict
double
float
@ -632,7 +636,7 @@ tcl::namespace::eval punk::args {
from existing definitions (by id) for re-use of argument specifications and help text)
e.g the following definition passes 2 blocks as text arguments
${[punk::args::tclcore::argdoc::example {
${[punk::args::moduledoc::tclcore::argdoc::example {
punk::args::define {
@id -id ::myns::myfunc
@cmd -name myns::myfunc -help\
@ -764,24 +768,25 @@ tcl::namespace::eval punk::args {
if {[dict exists $rawdef_cache $args]} {
return [dict get [dict get $rawdef_cache $args] -id]
} else {
set id [rawdef_id $args]
set lvl 2
set id [rawdef_id $args $lvl]
if {[id_exists $id]} {
#we seem to be re-creating a previously defined id...
#clear any existing caches for this id
puts stderr "punk::args::define Redefinition of id:$id - clearing existing data"
undefine $id 0
#dict unset argdata_cache $prevraw ;#silently does nothing if key not present
dict for {k v} $argdata_cache {
if {[dict get $v id] eq $id} {
dict unset argdata_cache $k
}
}
dict for {k v} $rawdef_cache {
if {[dict get $v -id] eq $id} {
dict unset rawdef_cache $k
}
}
dict unset id_cache_rawdef $id
##dict unset argdata_cache $prevraw ;#silently does nothing if key not present
#dict for {k v} $argdata_cache {
# if {[dict get $v id] eq $id} {
# dict unset argdata_cache $k
# }
#}
#dict for {k v} $rawdef_cache {
# if {[dict get $v -id] eq $id} {
# dict unset rawdef_cache $k
# }
#}
#dict unset id_cache_rawdef $id
}
set is_dynamic [rawdef_is_dynamic $args]
set defspace [uplevel 1 {::namespace current}]
@ -790,6 +795,35 @@ tcl::namespace::eval punk::args {
return $id
}
}
proc undefine {id {quiet 0}} {
variable rawdef_cache
variable id_cache_rawdef
variable argdata_cache
if {[id_exists $id]} {
if {!$quiet} {
puts stderr "punk::args::undefine clearing existing data for id:$id"
}
dict for {k v} $argdata_cache {
if {[dict get $v id] eq $id} {
dict unset argdata_cache $k
}
}
dict for {k v} $rawdef_cache {
if {[dict get $v -id] eq $id} {
dict unset rawdef_cache $k
}
}
dict unset id_cache_rawdef $id
} else {
if {!$quiet} {
puts stderr "punk::args::undefine unable to find id: '$id'"
}
}
}
#'punk::args::parse $args withdef $deflist' can raise parsing error after an autoid was generated
# In this case we don't see the autoid in order to delete it
#proc undefine_deflist {deflist} {
#}
proc idquery_info {id} {
variable id_cache_rawdef
@ -889,7 +923,8 @@ tcl::namespace::eval punk::args {
set textargs $args
if {![llength $args]} {
punk::args::get_by_id ::punk::args::define {}
#punk::args::get_by_id ::punk::args::define {}
punk::args::parse {} -errorstyle minimal withid ::punk::args::define
return
}
#if {[lindex $args 0] eq "-dynamic"} {
@ -1184,7 +1219,7 @@ tcl::namespace::eval punk::args {
}
ref {
#a reference within the definition
#e.g see punk::args::tclcore ::after
#e.g see punk::args::moduledoc::tclcore ::after
#global reference dict - independent of forms
#ignore refs without an -id
#store all keys except -id
@ -1952,6 +1987,7 @@ tcl::namespace::eval punk::args {
char - character {set normtype char}
dict - dictionary {set normtype dict}
index - indexexpression {set normtype indexexpression}
indexset {set normtype indexset}
"" - none - solo {
if {$is_opt} {
#review - are we allowing clauses for flags?
@ -1975,6 +2011,10 @@ tcl::namespace::eval punk::args {
}
}
any - anything {set normtype any}
unknown {
#'unspecified' ??
set normtype unknown
}
ansi - ansistring {set normtype ansistring}
string - globstring {set normtype $lc_firstword}
literal {
@ -2705,25 +2745,38 @@ tcl::namespace::eval punk::args {
#@dynamic only has meaning as 1st element of a def in the deflist
}
#@id must be within first 4 lines of a block - or assign auto
#@id must be within first 4 lines of first 3 blocks - or assign auto
#review - @dynamic block where -id not explicitly set? - disallow?
proc rawdef_id {rawdef} {
proc rawdef_id {rawdef {lvl 1}} {
set id ""
foreach d $rawdef {
set found_id_line 0
foreach d [lrange $rawdef 0 2] {
foreach ln [lrange [split $d \n] 0 4] {
if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} {
if {$firstword eq "@id"} {
set found_id_line 1
#review - uplevel 2 would be a call from punk::args::define ??
set rest [uplevel $lvl [list punk::args::lib::tstr -allowcommands $rest]]
if {[llength $rest] %2 == 0 && [dict exists $rest -id]} {
set id [dict get $rest -id]
break
}
break
}
}
}
if {$id ne ""} {
if {$found_id_line} {
break
}
}
if {$id eq "" && $found_id_line} {
#Looked like an @id - but presumable the rest of the line was malformed.
#we won't produce an autoid for such a definition.
set first3blocks ""
foreach b [lrange $rawdef 0 2] {
append first3blocks $b\n
}
error "punk::args::rawdef_id found an @id line in the first 4 lines of one of the 1st 3 blocks - but failed to retrieve a value for it.\nraw_def 1st 3 blocks:\n$first3blocks"
}
if {$id eq "" || [string tolower $id] eq "auto"} {
variable id_counter
set id "autoid_[incr id_counter]"
@ -2916,7 +2969,9 @@ tcl::namespace::eval punk::args {
set seen_documentedns [list] ;#seen per pkgns
foreach definitionlist [set ${pkgns}::PUNKARGS] {
#namespace eval $evalns [list punk::args::define {*}$definitionlist]
set id [rawdef_id $definitionlist]
#set id [rawdef_id $definitionlist]
set lvl 1 ;#level at which tstr substitution occurs in @id line
set id [namespace eval $pkgns [list punk::args::rawdef_id $definitionlist $lvl]]
if {[string match autoid_* $id]} {
puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping"
puts stderr "definition:\n"
@ -2958,6 +3013,9 @@ tcl::namespace::eval punk::args {
} else {
set needed [list]
foreach pkgns $nslist {
if {[string match (autodef)* $pkgns]} {
set pkgns [string range $pkgns 9 end]
}
if {![string match ::* $pkgns]} {
puts stderr "warning: update_definitions received unqualified ns: $pkgns"
set pkgns ::$pkgns
@ -3443,18 +3501,28 @@ tcl::namespace::eval punk::args {
set docname [Dict_getdef $spec_dict doc_info -name "Manual:"]
set docurl [Dict_getdef $spec_dict doc_info -url ""]
#set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""]
#set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""]
#if {"$argdisplay_header$argdisplay_body" eq ""} {
# set is_custom_argdisplay 0
#} else {
# set is_custom_argdisplay 1
#}
#temp - TODO
#review - when can there be more than one selected form?
set argdisplay_header ""
set argdisplay_body ""
set is_custom_argdisplay 0
if {[llength $selected_forms] == 1} {
set fid [lindex $selected_forms 0]
set FRM [dict get $spec_dict FORMS $fid]
if {[dict size [dict get $FRM FORMDISPLAY]]} {
set argdisplay_header [Dict_getdef $FRM FORMDISPLAY -header ""]
set argdisplay_body [Dict_getdef $FRM FORMDISPLAY -body ""]
}
}
# if {![dict size $F $fid $FORMDISPLAY]} {}
#set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""]
#set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""]
if {"$argdisplay_header$argdisplay_body" eq ""} {
set is_custom_argdisplay 0
} else {
set is_custom_argdisplay 1
}
#set is_custom_argdisplay 0
set blank_header_col [list]
@ -4335,7 +4403,7 @@ tcl::namespace::eval punk::args {
documentation generated dynamically and may not yet have an id.
IDs for autogenenerated help are prefixed e.g (autodef)::myensemble.
Generally punk::ns::arginfo (aliased as i in the punk shell) should
Generally punk::ns::cmdhelp (aliased as i in the punk shell) should
be used in preference - as it will search for a documentation
mechanism and call punk::args::usage as necessary.
"
@ -5730,6 +5798,15 @@ tcl::namespace::eval punk::args {
break
}
}
indexset {
if {![punk::lib::is_indexset $e_check]} {
set msg "$argclass $argname for %caller% requires type indexset. A comma-delimited set of indexes or index-ranges separated by '..' Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
} else {
lset clause_results $c_idx $a_idx 1
break
}
}
string - ansistring - globstring {
#we may commonly want exceptions that ignore validation rules - most commonly probably the empty string
#we possibly don't want to always have to regex on things that don't pass the other more basic checks
@ -8729,7 +8806,7 @@ tcl::namespace::eval punk::args {
}
set type_expression [string trim $typespec ?]
if {$type_expression in {any none}} {
if {$type_expression in {any none unknown}} {
continue
}
#puts "$argname - switch on type_expression: $type_expression v:[lindex $vlist $clausecolumn]"
@ -8790,7 +8867,8 @@ tcl::namespace::eval punk::args {
dict set finalopts $o $v
}
}
return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived]
set docid [dict get $argspecs id]
return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived id $docid]
}
lappend PUNKARGS [list {
@ -9570,8 +9648,15 @@ tcl::namespace::eval punk::args {
}
}
set cinfo [punk::ns::resolve_command {*}$cmd]
set tp [dict get $cinfo cmdtype]
#don't use full cmdinfo if $cmd is a single element
if {[llength $cmd] == 1} {
set cinfo [punk::ns::cmdwhich $cmd]
set tp [dict get $cinfo whichtype]
} else {
puts stderr "WARNING ==ensemble_subcommands_definition== cmdinfo $cmd\n$cinfo"
set cinfo [punk::ns::cmdinfo {*}$cmd]
set tp [dict get $cinfo cmdtype]
}
dict set choiceinfodict $sc [list [list resolved $cmd]]
@ -9584,9 +9669,23 @@ tcl::namespace::eval punk::args {
}
}
if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} {
#could be more than one punk::args id - choose a precedence by how we order the id_exists checks.
if {[punk::args::id_exists [list $ensemble $sc]]} {
dict lappend choiceinfodict $sc {doctype punkargs}
dict lappend choiceinfodict $sc [list subhelp {*}$ensemble $sc]
} elseif {[punk::args::id_exists $cmd]} {
dict lappend choiceinfodict $sc {doctype punkargs}
dict lappend choiceinfodict $sc [list subhelp {*}$cmd]
} elseif {[punk::args::id_exists [dict get $cinfo origin]]} {
dict lappend choiceinfodict $sc {doctype punkargs}
dict lappend choiceinfodict $sc [list subhelp {*}[dict get $cinfo origin]]
} else {
#puts stderr "ensemble_subcommands_definition--- NO doc for [list $ensemble $sc] or $cmd or [dict get $cinfo origin]"
}
#if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} {
# dict lappend choiceinfodict $sc {doctype punkargs}
#}
}
set argdef ""
@ -9699,9 +9798,18 @@ tcl::namespace::eval punk::args::lib {
ooc {
lappend marks [punk::ns::Cmark ooc cyan]
}
classmethod {
lappend marks [punk::ns::Cmark classmethod term-orange1]
}
coremethod {
lappend marks [punk::ns::Cmark coremethod term-plum1]
}
ooo {
lappend marks [punk::ns::Cmark ooo cyan]
}
objectmethod {
lappend marks [punk::ns::Cmark objectmethod term-orange1]
}
native {
lappend marks [punk::ns::Cmark native]
}
@ -9724,11 +9832,11 @@ tcl::namespace::eval punk::args::lib {
@id -id ::punk::args::lib::tstr
@cmd -name punk::args::lib::tstr\
-summary\
"Templating with \$\{$varName\}"\
"Templating with placeholders such as: \$\{$varName\}"\
-help\
"A rough equivalent of js template literals
"Roughly analogous to js template literals
Substitutions:
Placeholder Substitutions:
\$\{$varName\}
\$\{[myCommand]\}
(when -allowcommands flag is given)"

7031
src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm

File diff suppressed because it is too large Load Diff

195
src/bootsupport/modules/punk/args/tclcore-0.1.0.tm

@ -4988,7 +4988,8 @@ tcl::namespace::eval punk::args::tclcore {
obsolete {variable vdelete vinfo}
}\
-choiceinfo {
add {{doctype punkargs} {subhelp ::trace add}}
add {{doctype punkargs} {subhelp ::trace add}}
remove {{doctype punkargs} {subhelp ::trace remove}}
}
@values -min 0 -max 0
@ -4996,23 +4997,30 @@ tcl::namespace::eval punk::args::tclcore {
punk::args::define {
@id -id "::trace add"
@cmd -name "Built-in: trace add" -help\
""
@cmd -name "Built-in: trace add"\
-summary\
"Add a command, execution or variable trace."\
-help\
"Add a command, execution or variable trace."
@form -synopsis "trace add type name ops ?args?"
@leaders
type -choicegroups {
"" {command execution variable}
}\
-choiceinfo {
command {{doctype punkargs}}
execution {{doctype punkargs}}
command {{doctype punkargs} {subhelp ::trace add command}}
execution {{doctype punkargs} {subhelp ::trace add execution}}
variable {{doctype punkargs}}
}
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace add command"
@cmd -name "Built-in: trace add command" -help\
@cmd -name "Built-in: trace add command"\
-summary\
"Add command trace for operation(s): rename delete"\
-help\
"Arrange for commandPrefix to be executed (with additional arguments)
whenever command name is modified in one of the ways given by the list
ops. Name will be resolved using the usual namespace resolution rules
@ -5056,10 +5064,126 @@ tcl::namespace::eval punk::args::tclcore {
"
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace add variable"
@cmd -name "Built-in: trace add variable"\
-summary\
"Add variable trace for operation(s): array read write unset."\
-help\
"Arrange for commandPrefix to be executed whenever variable name is accessed
in one of the ways given by the list ops. Name may refer to a normal variable,
an element of an array, or to an array as a whole (i.e. name may be just the
name of an array, with no parenthesized index). If name refers to a whole
array, then commandPrefix is invoked whenever any element of the array is
manipulated. If the variable does not exist, it will be created but will not
be given a value, so it will be visible to namespace which queries, but not to
info exists queries."
name -type string -help\
"Name of variable"
# ---------------------------------------------------------------
ops -type list -choices {array read write unset} -choiceprefix 0\
-choicemultiple {1 4}\
-choicecolumns 1\
-choicelabels {
array\
" Invoke commandPrefix whenever the variable is accessed or
modified via the array command, provided that name is not a
scalar variable at the time that the array command is invoked.
If name is a scalar variable, the access via the array command
will not trigger the trace."
read\
" Invoke commandPrefix whenever the variable isread."
write\
" Invoke commandPrefix whenever the variable is written."
unset\
" Invoke commandPrefix whenever the variable is unset. Variables
can be unset explicitly with the unset command, or implicitly
when procedures return (all of their local variables are unset).
Variables are also unset when interpreters are deleted, but
traces will not be invoked because there is no interpreter in
which to execute them."
}\
-help\
"Indicates which operations are of interest."
commandPrefix -type string -help\
"When the trace triggers, three arguments are appended to commandPrefix
so that the actual command is as follows:
-----------------------------------------
commandPrefix name1 name2 op
-----------------------------------------
Name1 gives the name for the variable being accessed. This is not
necessarily the same as the name used in the trace add variable command:
the upvar command allows a procedure to reference a variable under a
different name. If the trace was originally set on an array or array
element, name2 provides which index into the array was affected. This
information is present even when name1 refers to a scalar, which may
happen if the upvar command was used to create a reference to a single
array element. If an entire array is being deleted and the trace was
registered on the overall array, rather than a single element, then
name1 gives the array name and name2 is an empty string. Op indicates
what operation is being performed on the variable, and is one of read,
write, or unset as defined above.
CommandPrefix executes in the same context as the code that invoked the
traced operation: if the variable was accessed as part of a Tcl procedure,
then commandPrefix will have access to the same local variables as code in
the procedure. This context may be different than the context in which the
trace was created. If commandPrefix invokes a procedure (which it normally
does) then the procedure will have to use upvar or uplevel if it wishes to
access the traced variable. Note also that name1 may not necessarily be
the same as the name used to set the trace on the variable; differences
can occur if the access is made through a variable defined with the upvar
command.
For read and write traces, commandPrefix can modify the variable to affect
the result of the traced operation. If commandPrefix modifies the value of
a variable during a read or write trace, then the new value will be
returned as the result of the traced operation. The return value from
commandPrefix is ignored except that if it returns an error of any sort
then the traced operation also returns an error with the same error message
returned by the trace command (this mechanism can be used to implement
read-only variables, for example). For write traces, commandPrefix is
invoked after the variable's value has been changed; it can write a new
value into the variable to override the original value specified in the
write operation. To implement read-only variables, commandPrefix will have
to restore the old value of the variable.
While commandPrefix is executing during a read or write trace, traces on
the variable are temporarily disabled. This means that reads and writes
invoked by commandPrefix will occur directly, without invoking
commandPrefix (or any other traces) again. However, if commandPrefix
unsets the variable then unset traces will be invoked.
When an unset trace is invoked, the variable has already been deleted: it
will appear to be undefined with no traces. If an unset occurs because of
a procedure return, then the trace will be invoked in the variable context
of the procedure being returned to: the stack frame of the returning
procedure will no longer exist. Traces are not disabled during unset
traces, so if an unset trace command creates a new trace and accesses the
variable, the trace will be invoked. Any errors in unset traces are ignored.
If there are multiple traces on a variable they are invoked in order of
creation, most-recent first. If one trace returns an error, then no further
traces are invoked for the variable. If an array element has a trace set,
and there is also a trace set on the array as a whole, the trace on the
overall array is invoked before the one on the element.
Once created, the trace remains in effect either until the trace is removed
with the trace remove variable command described below, until the variable
is unset, or until the interpreter is deleted. Unsetting an element of array
will remove any traces on that element, but will not remove traces on the
overall array.
This command returns an empty string."
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace add execution"
@cmd -name "Built-in: trace add execution" -help\
@cmd -name "Built-in: trace add execution"\
-summary\
"Add execution trace for operation(s): enter leave enterstep leavestep."\
-help\
"Arrange for commandPrefix to be executed (with additional arguments)
whenever command name is executed, with traces occurring at the points
indicated by the list ops. Name will be resolved using the usual namespace
@ -5159,6 +5283,25 @@ tcl::namespace::eval punk::args::tclcore {
"
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace remove"
@cmd -name "Built-in: trace remove"\
-summary\
"Remove a command, execution or variable trace."\
-help\
"Remove a command, execution or variable trace."
@form -synopsis "trace remove type name ops ?args?"
@leaders
type -choicegroups {
"" {command execution variable}
}\
-choiceinfo {
command {{doctype punkargs} {subhelp ::trace remove command}}
execution {{doctype punkargs} {subhelp ::trace remove execution}}
variable {{doctype punkargs} {subhelp ::trace remove variable}}
}
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace remove command"
@cmd -name "Built-in: trace remove command" -help\
@ -5175,6 +5318,44 @@ tcl::namespace::eval punk::args::tclcore {
delete"
commandPrefix
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace remove execution"
@cmd -name "Built-in: trace remove execution" -help\
"If there is a trace set on command name with the operations and command
given by opList and commandPrefix, then the trace is removed, so that
commandPrefix will never again be invoked. Returns an empty string. If
name does not exist, the command will throw an error"
@values
name -type string -help\
"Name of command"
opList -type list -help\
"A list of one or more of the following items:
enter
leave
enterstep
leavestep"
commandPrefix
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace remove variable"
@cmd -name "Built-in: trace remove variable" -help\
"If there is a trace set on command name with the operations and command
given by opList and commandPrefix, then the trace is removed, so that
commandPrefix will never again be invoked. Returns an empty string."
@values
name -type string -help\
"Name of command"
opList -type list -help\
"A list of one or more of the following items:
array
read
write
unset"
commandPrefix
} "@doc -name Manpage: -url [manpage_tcl trace]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---

123
src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm

@ -66,12 +66,14 @@ namespace eval punk::cap::handlers::templates {
set multivendor_package_whitelist [list punk::mix::templates]
#for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the projectbase rather than rechecking it each time the templates handler api is called
#for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the base rather than rechecking it each time the templates handler api is called
#for template pathtype absolute - we can do the same.
#There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change.
#adhoc and currentproject* paths are relative to cwd - so no projectbase information can be stored at registration time.
#not all template item types will need projectbase information - as the item data may be self-contained within the template structure -
#adhoc and currentproject* pathtypes are relative to cwd - so no base information can be stored at registration time.
#module pathtype base is resolved by the providing package itself at load time using 'info script'
#not all template item types will need base information - as the item data may be self-contained within the template structure -
#but project_layout will need it - or at least need to know if there is no project - because project_layout data is never stored in the template folder structure directly.
switch -- $pathtype {
adhoc {
@ -86,44 +88,19 @@ namespace eval punk::cap::handlers::templates {
if {[file pathtype $path] ne "relative"} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
}
#todo - check for mounted modpod (or tarjar?)
#e.g //zipfs:/#modpod/d1/d2/#mounted-modpod-libname-V.v
#(or equivalent for vfs eg c:/repo/jn/shellspy/modules/test/#modpod/test/#mounted-modpod-libname-V.v
set provide_statement [package ifneeded $pkg [package require $pkg]]
set tmfile [lindex $provide_statement end]
if {[interp issafe]} {
#default safe interp can't use file exists/normalize etc.. but safe interp may have a policy/alias set allowing file access to certain paths - so test if file exists is usable
if {[catch {file exists $tmfile} tm_exists]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING (expected in most safe interps) - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
flush stderr
return 0
}
} else {
set tm_exists [file exists $tmfile]
}
if {!$tm_exists} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
flush stderr
#The package should have provided a base folder (by using 'info script') when it was loaded
#'package ifneeded' for a module gives initial path information for a package - but it might redirect to sourcing from a different location such as being mounted elsewhere in a vfs,
#in which case we wouldn't get the correct path.
if {![dict exists $capdict base]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing the 'base' key (required when pathtype is 'module')"
return 0
}
set tmfolder [file dirname $tmfile]
#todo - handle wrapped or unwrapped tarjar files - in which case we have to adjust tmfolder appropriately
#set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder
#set projectinfo [punk::repo::find_repos $tmfolder] ;#slow - REVIEW
#REVIEW - do we even want project base relative to where the lib came from??
#should be relative to executable? or cwd?
set projectbase [punk::repo::find_project $tmfolder]
#store the projectbase even if it's empty string
set extended_capdict $capdict
set resolved_path [file join $tmfolder $path]
set base [dict get $capdict base]
set resolved_path [file join $base $path]
dict set extended_capdict resolved_path $resolved_path
dict set extended_capdict projectbase $projectbase
dict set extended_capdict base $base
}
currentproject_multivendor {
#currently only intended for punk::mix::templates - review if 3rd party _multivendor trees even make sense
@ -156,14 +133,18 @@ namespace eval punk::cap::handlers::templates {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
return 0
}
set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
#set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
set shellbase [file dirname [file dirname [file normalize [info nameofexecutable]/___]]]
#set projectinfo [punk::repo::find_repos $shellbase]
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $shellbase]
#set base [dict get $projectinfo closest]
#may result in empty base for no project found
set base [punk::repo::find_project $shellbase]
set extended_capdict $capdict
dict set extended_capdict vendor $vendor
dict set extended_capdict projectbase $projectbase
dict set extended_capdict base $base
}
shellproject_multivendor {
#currently only intended for punk::templates - review if 3rd party _multivendor trees even make sense
@ -175,14 +156,15 @@ namespace eval punk::cap::handlers::templates {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
return 0
}
set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
#set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
set shellbase [file dirname [file dirname [file normalize [info nameofexecutable]/___]]]
#set projectinfo [punk::repo::find_repos $shellbase]
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $shellbase]
#set base [dict get $projectinfo closest]
set base [punk::repo::find_project $shellbase]
set extended_capdict $capdict
dict set extended_capdict vendor $vendor
dict set extended_capdict projectbase $projectbase
dict set extended_capdict base $base
}
absolute {
if {[file pathtype $path] ne "absolute"} {
@ -194,15 +176,12 @@ namespace eval punk::cap::handlers::templates {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' which doesn't seem to exist"
return 0
}
#set projectinfo [punk::repo::find_repos $normpath]
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $normpath]
#todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder
set extended_capdict $capdict
dict set extended_capdict resolved_path $normpath
dict set extended_capdict vendor $vendor
dict set extended_capdict projectbase $projectbase
dict set extended_capdict base ""
}
default {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' with unrecognised type $pathtype"
@ -332,16 +311,16 @@ namespace eval punk::cap::handlers::templates {
set path [dict get $capdecl_extended path]
set pathtype [dict get $capdecl_extended pathtype]
set vendor [dict get $capdecl_extended vendor]
# projectbase not present in capdecl_extended for all template pathtypes
# base not present in capdecl_extended for all template pathtypes ?
if {$pathtype eq "adhoc"} {
#e.g (cwd)/templates
set targetpath [file join $startdir [dict get $capdecl_extended path]]
if {[file isdirectory $targetpath]} {
dict lappend found_paths_adhoc $vendor [list pkg $pkg path $targetpath pathtype $pathtype]
dict lappend found_paths_adhoc $vendor [list pkg $pkg path $targetpath pathtype $pathtype base $startdir]
}
} elseif {$pathtype eq "module"} {
set module_projectroot [dict get $capdecl_extended projectbase]
dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot]
set mbase [dict get $capdecl_extended base]
dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype base $mbase]
} elseif {$pathtype eq "currentproject_multivendor"} {
#set searchbase $startdir
#set pathinfo [punk::repo::find_repos $searchbase]
@ -357,11 +336,11 @@ namespace eval punk::cap::handlers::templates {
set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *]
foreach vf $vendorfolders {
if {$vf ne "_project"} {
dict lappend found_paths_currentproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype]
dict lappend found_paths_currentproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype base $pwd_projectroot]
}
}
if {[file isdirectory [file join $vendorbase _project]]} {
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype]
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype base $pwd_projectroot]
}
}
set custombase [file join $deckbase custom]
@ -369,11 +348,11 @@ namespace eval punk::cap::handlers::templates {
set customfolders [glob -nocomplain -dir $custombase -type d -tails *]
foreach cf $customfolders {
if {$cf ne "_project"} {
dict lappend found_paths_currentproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype]
dict lappend found_paths_currentproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype base $pwd_projectroot]
}
}
if {[file isdirectory [file join $custombase _project]]} {
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype]
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype base $pwd_projectroot]
}
}
}
@ -385,7 +364,7 @@ namespace eval punk::cap::handlers::templates {
#path relative to projectroot already validated by handler as being within a currentproject_multivendor tree
set targetfolder [file join $pwd_projectroot $path]
if {[file isdirectory $targetfolder]} {
dict lappend found_paths_currentproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype]
dict lappend found_paths_currentproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype base $pwd_projectroot]
}
}
} elseif {$pathtype eq "shellproject_multivendor"} {
@ -394,7 +373,7 @@ namespace eval punk::cap::handlers::templates {
#set pathinfo [punk::repo::find_repos $shellbase]
#set pwd_projectroot [dict get $pathinfo closest]
set shell_projectroot [dict get $capdecl_extended projectbase]
set shell_projectroot [dict get $capdecl_extended base]
if {$shell_projectroot ne ""} {
set deckbase [file join $shell_projectroot $path]
if {![file exists $deckbase]} {
@ -406,11 +385,11 @@ namespace eval punk::cap::handlers::templates {
set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *]
foreach vf $vendorfolders {
if {$vf ne "_project"} {
dict lappend found_paths_shellproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype base $shell_projectroot]
}
}
if {[file isdirectory [file join $vendorbase _project]]} {
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype base $shell_projectroot]
}
}
set custombase [file join $deckbase custom]
@ -418,11 +397,11 @@ namespace eval punk::cap::handlers::templates {
set customfolders [glob -nocomplain -dir $custombase -type d -tails *]
foreach cf $customfolders {
if {$cf ne "_project"} {
dict lappend found_paths_shellproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype base $shell_projectroot]
}
}
if {[file isdirectory [file join $custombase _project]]} {
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype base $shell_projectroot]
}
}
@ -434,17 +413,17 @@ namespace eval punk::cap::handlers::templates {
#set pathinfo [punk::repo::find_repos $shellbase]
#set pwd_projectroot [dict get $pathinfo closest]
set shell_projectroot [dict get $capdecl_extended projectbase]
set shell_projectroot [dict get $capdecl_extended base]
if {$shell_projectroot ne ""} {
set targetfolder [file join $shell_projectroot $path]
if {[file isdirectory $targetfolder]} {
dict lappend found_paths_shellproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype base $shell_projectroot]
}
}
} elseif {$pathtype eq "absolute"} {
#lappend found_paths [dict get $capdecl_extended resolved_path]
set abs_projectroot [dict get $capdecl_extended projectbase]
dict lappend found_paths_absolute $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $abs_projectroot]
set abs_projectroot [dict get $capdecl_extended base]
dict lappend found_paths_absolute $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype base $abs_projectroot]
}
}
@ -460,19 +439,19 @@ namespace eval punk::cap::handlers::templates {
dict for {vendor pathinfolist} $found_paths_module {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor]
}
}
#Templates within project of shell we launched with has lower priority than 'currentproject' (which depends on our CWD)
dict for {vendor pathinfolist} $found_paths_shellproject_multivendor {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor]
}
}
dict for {vendor pathinfolist} $found_paths_shellproject {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor]
}
}
@ -488,7 +467,7 @@ namespace eval punk::cap::handlers::templates {
}
dict for {vendor pathinfolist} $found_paths_absolute {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor]
}
}
#adhoc paths relative to cwd (or specified -startdir) can override any
@ -540,9 +519,9 @@ namespace eval punk::cap::handlers::templates {
set tailats [join [lrange $atparts 1 end] @]
# @ parts after the first are part of the path within the project_layouts structure
set subpathlist [split $tailats +]
if {[dict exists $refinfo sourceinfo projectbase]} {
if {[dict exists $refinfo sourceinfo base]} {
#some template pathtypes refer to the projectroot from the template - not the cwd
set ref_projectroot [dict get $refinfo sourceinfo projectbase]
set ref_projectroot [dict get $refinfo sourceinfo base]
} else {
set ref_projectroot $projectroot
}

143
src/bootsupport/modules/punk/lib-0.1.2.tm

@ -497,78 +497,6 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}]
}
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed)
proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
set ns_mapped [string map {:: \uFFFF} $ns]
#puts stderr "aliases ns: $ns_mapped"
set segments [split $ns_mapped \uFFFF] ;#include empty string before leading ::
if {![string length [lindex $segments end]]} {
#special case for :: only include leading segment rather thatn {} {}
set segments [lrange $segments 0 end-1]
}
set segcount [llength $segments] ;#only match number of segments matching current ns
set all_aliases [interp aliases {}]
set matched [list]
foreach a $all_aliases {
#normalize with leading ::
if {![string match ::* $a]} {
set abs ::$a
} else {
set abs $a
}
set asegs [split [string map {:: \uFFFF} $abs] \uFFFF]
set acount [llength $asegs]
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments"
if {($acount - 1) == $segcount} {
if {[lrange $asegs 0 end-1] eq $segments} {
if {[string match $glob [lindex $asegs end]]} {
#report this alias in the current namespace - even though there may be no matching command
lappend matched $a ;#add raw alias token which may or may not have leading ::
}
}
}
}
#set matched_abs [lsearch -all -inline $all_aliases $glob]
return $matched
}
proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
if {[llength $args]} {
if {$aliasorglob in [interp aliases ""]} {
set existing [interp alias "" $aliasorglob]
puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)"
}
if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} {
#use empty string/whitespace as intention to delete alias
return [interp alias "" $aliasorglob ""]
}
return [interp alias "" $aliasorglob "" {*}$args]
} else {
if {![string length $aliasorglob]} {
set aliaslist [punk::lib::aliases]
puts -nonewline stderr $aliaslist
return
}
#we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias
set target [interp alias "" $aliasorglob]
if {[llength $target]} {
return $target
}
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} {
set aliaslist [punk::lib::aliases $aliasorglob]
puts -nonewline stderr $aliaslist
return
}
return [list]
}
}
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
@ -2242,7 +2170,51 @@ namespace eval punk::lib {
}
}
punk::args::define {
@id -id ::punk::lib::is_indexset
@cmd -name punk::lib::is_indexset\
-summary\
"Validate string is a comma-delimited 'indexset'."\
-help\
"Validate that a string is an 'indexset'
An indexset consists of a comma delimited list of indexes or index-ranges.
The indexes are 0-based.
Ranges must be specified with .. as the separator.
Common whitespace elements space,tab,newlines are ignored.
Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands,
e.g end-2 or 2+2.
see indexset_resolve"
@values -min 2 -max 2
indexset -type string
}
proc is_indexset {indexset} {
#collapse internal whitespace (for basic whitespace set we allow)
set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset]
if {![regexp {^[\-\+_end,\.0-9]*$} $indexset]} {
return 0
}
set ranges [split $indexset ,]
foreach r $ranges {
set validateindices [list]
set rposn [string first .. $r]
if {$rposn >= 0} {
lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end]
} else {
#'range' is just an index
set validateindices [list $r]
}
foreach v $validateindices {
if {$v eq "" || $v eq "end"} {continue}
if {[string is integer -strict $v]} {continue}
if {[catch {lindex {} $v}]} {
return 0
}
}
}
return 1
}
#review - compare to IMAP4 methods of specifying ranges?
punk::args::define {
@id -id ::punk::lib::indexset_resolve
@ -2251,6 +2223,8 @@ namespace eval punk::lib {
"Resolve an indexset to a list of integers based on supplied list or string length."\
-help\
"Resolve an 'indexset' to a list of actual indices within the range of the provided numitems value.
e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9
An indexset consists of a comma delimited list of indexes or index-ranges.
The indexes are 0-based.
Ranges must be specified with .. as the separator.
@ -2258,27 +2232,30 @@ namespace eval punk::lib {
Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands,
e.g end-2 or 2+2.
end means the last page.
end-1 means the second last page.
end means the last item.
end-1 means the second last item.
0.. is the same as 0..end.
examples:
indexset examples:
1,3..
output the page index 1 (2nd page) followed by all from index 3 to the end.
output the index 1 (2nd item) followed by all from index 3 to the end.
'indexset_resolve 4 1,3..' -> 1 3
'indexset_resolve 10 1,3..' -> 1 3 4 5 6 7 8 9
0-2,end
output the first 3 pages, and the last page.
output the first 3 indices, and the last index.
end-1..0
output the indexes in reverse order from 2nd last page to first page."
output the indexes in reverse order from 2nd last item to first item."
@values -min 2 -max 2
numitems -type integer
indexset -type string
indexset -type indexset -help "comma delimited specification for indices to return"
}
proc indexset_resolve {numitems indexset} {
if {![string is integer -strict $numitems] || ![regexp {^[\-\+_end,\.0-9]*$} $indexset]} {
if {![string is integer -strict $numitems] || ![is_indexset $indexset]} {
#use parser on unhappy path only
set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve]
uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg]
}
set index_list [list] ;#list of actual indexes within the range
}
set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace
set index_list [list] ;#list of actual indexes within the range
set iparts [split $indexset ,]
set index_list [list]
foreach ipart $iparts {
@ -2286,7 +2263,7 @@ namespace eval punk::lib {
set rposn [string first .. $ipart]
if {$rposn>=0} {
#range
lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb
lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb
set rawa [string trim $rawa]
set rawb [string trim $rawb]
if {$rawa eq ""} {set rawa 0}

4
src/bootsupport/modules/punk/libunknown-0.1.tm

@ -1,5 +1,5 @@
# -*- tcl -*-
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
@ -17,7 +17,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::libunknown 0 0.1]
#[manpage_begin punkshell_module_punk::libunknown 0 0.1]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]

5
src/bootsupport/modules/punk/mix-0.2.tm

@ -7,6 +7,11 @@ tcl::namespace::eval punk::mix {
package require punk::cap::handlers::templates ;#handler for templates cap
punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us
#todo: use tcllib pluginmgr to load all modules that provide 'punk.templates'
#review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages
#We may also need to better control the order of module and library paths in the safe interps pluginmgr uses.
#todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation)
package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap
set t [time {
if {[catch {punk::mix::templates::provider register *} errM]} {

14
src/bootsupport/modules/punk/mix/cli-0.3.1.tm

@ -480,7 +480,7 @@ namespace eval punk::mix::cli {
}
#repotypes *could* be both git and fossil - so report both if so
if {"git" in $repotypes} {
append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n
append result "\nGIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n
if {[string length [set git_prog [auto_execok git]]]} {
set git_remotes [exec {*}$git_prog remote -v]
append result $git_remotes
@ -791,10 +791,10 @@ namespace eval punk::mix::cli {
if {[catch {
file copy -force $modulefile $target_module_dir
} errMsg]} {
puts stderr "FAILED to copy zip modpod module $modulefile to $target_module_dir"
puts stderr "[punk::ansi::a+ red]FAILED to copy zip modpod module $modulefile to $target_module_dir[punk::ansi::a]"
$event targetset_end FAILED -note "could not copy $modulefile"
} else {
puts stderr "Copied zip modpod module $modulefile to $target_module_dir"
puts stderr "[punk::ansi::a+ green]Copied zip modpod module $modulefile to $target_module_dir[punk::ansi::a]"
# -- --- --- --- --- ---
$event targetset_end OK -note "zip modpod"
}
@ -821,7 +821,7 @@ namespace eval punk::mix::cli {
if {$tmfile_versionsegment eq $magicversion} {
set versionfiledata ""
if {![file exists $versionfile]} {
puts stderr "\nWARNING: Missing buildversion text file: $versionfile"
puts stderr "\n[punk::ansi::a+ brightyellow]WARNING: Missing buildversion text file: $versionfile[punk::ansi::a]"
puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n"
set module_build_version "0.1"
} else {
@ -830,7 +830,7 @@ namespace eval punk::mix::cli {
set ln0 [lindex [split $versionfiledata \n] 0]
set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r]
if {![util::is_valid_tm_version $ln0]} {
puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file"
puts stderr "ERROR:[punk::ansi::a+ red] build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file[punk::ansi::a]"
exit 3
}
set module_build_version $ln0
@ -973,10 +973,10 @@ namespace eval punk::mix::cli {
if {[catch {
file copy -force $modulefile $target_module_dir
} errMsg]} {
puts stderr "FAILED to copy tarjar module $modulefile to $target_module_dir"
puts stderr "[punk::ansi::a+ red]FAILED to copy tarjar module $modulefile to $target_module_dir[punk::ansi::a]"
$event targetset_end FAILED -note "could not copy $modulefile"
} else {
puts stderr "Copied tarjar module $modulefile to $target_module_dir"
puts stderr "[punk::ansi::a+ green]Copied tarjar module $modulefile to $target_module_dir[punk::ansi::a]"
# -- --- --- --- --- ---
$event targetset_end OK -note "tarjar"
}

BIN
src/bootsupport/modules/punk/mix/templates-0.1.2.tm

Binary file not shown.

3414
src/bootsupport/modules/punk/ns-0.1.0.tm

File diff suppressed because it is too large Load Diff

2
src/bootsupport/modules/punk/packagepreference-0.1.0.tm

@ -328,7 +328,7 @@ tcl::namespace::eval punk::packagepreference {
catch {
#$COMMANDSTACKNEXT require $pkg {*}$vwant
#j2
$COMMANDSTACKNEXT require punk::args::$dp
$COMMANDSTACKNEXT require punk::args::moduledoc::$dp
}
}
#---------------------------------------------------------------

54
src/bootsupport/modules/punk/pipe-1.0.tm

@ -1,6 +1,6 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::pipe 0 1.0]
#[manpage_begin punkshell_module_punk::pipe 0 1.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
@ -61,48 +61,16 @@ package require Tcl 8.6-
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::pipe::class {
#*** !doctools
#[subsection {Namespace punk::pipe::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 ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::pipe {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection {Namespace punk::pipe}]
#[para] Core API functions for punk::pipe
#[para] Core API functions for punk::pipe
#[list_begin definitions]
@ -110,13 +78,13 @@ tcl::namespace::eval punk::pipe {
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1
# #[para]Description of sample1
# #[para] Arguments:
# # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n.
# # [list_end]
# return "ok"
# return "ok"
#}
#https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/
@ -735,16 +703,6 @@ tcl::namespace::eval punk::pipe::lib {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::pipe::system {
#*** !doctools
#[subsection {Namespace punk::pipe::system}]
#[para] Internal functions that are not part of the API
#}
# == === === === === === === === === === === === === === ===

25
src/bootsupport/modules/punk/repl-0.1.2.tm

@ -3063,6 +3063,11 @@ namespace eval repl {
return $stack
}
}
#autodoc for ensemble, or a punk::args::define doc here
#will not alow discovery of the documentation from within an interp that has
#only alias access to this - as the docs (indeed even the namespace) won't
#exist in the calling interp.
namespace eval ::repl::interphelpers::subshell_ensemble {
namespace export {[a-z]*}
namespace ensemble create
@ -3259,7 +3264,7 @@ namespace eval repl {
debug\
punk::ns\
textblock\
punk::args::tclcore\
punk::args::moduledoc::tclcore\
punk::aliascore\
]
@ -3333,8 +3338,8 @@ namespace eval repl {
#review
code alias ::shellfilter::stack ::shellfilter::stack
#code alias ::punk::lib::set_clone ::punk::lib::set_clone
#code alias ::aliases ::punk::lib::aliases
code alias ::punk::lib::aliases ::punk::lib::aliases
#code alias ::aliases ::punk::ns::aliases
code alias ::punk::ns::aliases ::punk::ns::aliases
namespace eval ::codeinterp {}
code alias ::md5::md5 ::repl::interphelpers::md5
@ -3443,7 +3448,7 @@ namespace eval repl {
interp eval code {
package require punk::lib
package require punk::args
catch {package require punk::args::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical
catch {package require punk::args::moduledoc::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical
package require textblock
}
@ -3614,7 +3619,7 @@ namespace eval repl {
}} [punk::config::configure running]
package require textblock
catch {package require punk::args::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical
catch {package require punk::args::moduledoc::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical
} errM]} {
puts stderr "========================"
puts stderr "code interp error:"
@ -3632,6 +3637,16 @@ namespace eval repl {
}
}
code alias repl ::repl::interphelpers::repl_ensemble
code eval {
punk::args::define {
@id -id ::subshell
@cmd -name ::subshell\
-summary "Launch in-process subshell"\
-help "Launch a thread-based subshell"
shellname -type string -optional 0 -choices {punk punksafe safe safebase}
}
}
code alias subshell ::repl::interphelpers::subshell_ensemble
code alias quit ::repl::interphelpers::quit
code alias editbuf ::repl::interphelpers::editbuf

1
src/bootsupport/modules/textblock-0.1.3.tm

@ -58,7 +58,6 @@ package require punk::args
package require punk::char
package require punk::ansi
package require punk::lib
catch {package require patternpunk}
package require overtype
package require struct::set

161
src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm vendored

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

12
src/project_layouts/custom/_project/punk.basic/src/make.tcl

@ -1760,9 +1760,10 @@ if {$::punkboot::command eq "vendorupdate"} {
set vendor_config $sourcefolder/vendormodules$which/include_modules.config ;#todo - change to toml
if {[file exists $vendor_config]} {
set targetroot $sourcefolder/vendormodules$which
set local_modules [list]
source $vendor_config ;#populate $local_modules $git_modules $fossil_modules with project-specific list
if {![llength $local_modules]} {
puts stderr "src/vendormodules$which No local vendor modules configured for updating (config file: $vendor_config)"
puts stderr "\nsrc/vendormodules$which No local vendor modules configured for updating (config file: $vendor_config)"
} else {
if {[catch {
#----------
@ -1775,10 +1776,15 @@ if {$::punkboot::command eq "vendorupdate"} {
set installation_event ""
}
#todo - sync alg with bootsupport_localupdate!
foreach {relpath requested_module} $local_modules {
foreach {localpath requested_module} $local_modules {
set requested_module [string trim $requested_module :]
set module_subpath [string map {:: /} [namespace qualifiers $requested_module]]
set srclocation [file join $projectroot $relpath $module_subpath]
if {[file pathtype $localpath] eq "relative"} {
#This would actually work for absolute paths too as file join c:/test c:/etc ignores first arg and returns c:/etc
set srclocation [file join $projectroot $localpath $module_subpath]
} else {
set srclocation [file join $localpath $module_subpath]
}
#puts stdout "$relpath $module $module_subpath $srclocation"
#todo - check if requested_module has version extension and allow explicit versions instead of just latest

3
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config

@ -23,6 +23,7 @@ set bootsupport_modules [list\
src/vendormodules patterncmd\
src/vendormodules patternlib\
src/vendormodules patternpredator2\
src/vendormodules patterncipher\
src/vendormodules promise\
src/vendormodules sha1\
src/vendormodules tomlish\
@ -50,7 +51,7 @@ set bootsupport_modules [list\
modules punk::ansi\
modules punk::assertion\
modules punk::args\
modules punk::args::tclcore\
modules punk::args::moduledoc::tclcore\
modules punk::cap\
modules punk::cap::handlers::caphandler\
modules punk::cap::handlers::scriptlibs\

5989
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.8.tm

File diff suppressed because it is too large Load Diff

1459
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncipher-0.1.1.tm

File diff suppressed because it is too large Load Diff

639
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncmd-1.2.8.tm

@ -0,0 +1,639 @@
package provide patterncmd [namespace eval patterncmd {
variable version
set version 1.2.8
}]
namespace eval pattern {
variable idCounter 1 ;#used by pattern::uniqueKey
namespace eval cmd {
namespace eval util {
package require overtype
variable colwidths_lib [dict create]
variable colwidths_lib_default 15
dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""]
dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""]
dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""]
dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"]
proc colhead {type args} {
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
set line ""
foreach colname [dict keys $colwidths] {
append line "[col $type $colname [string totitle $colname] {*}$args]"
}
return $line
}
proc colbreak {type} {
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
set line ""
foreach colname [dict keys $colwidths] {
append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]"
}
return $line
}
proc col {type col val args} {
# args -head bool -tail bool ?
#----------------------------------------------------------------------------
set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify]
dict set default -backchar ""
dict set default -headchar ""
dict set default -tailchar ""
dict set default -headoverridechar ""
dict set default -tailoverridechar ""
dict set default -justify "left"
if {([llength $args] % 2) != 0} {
error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' "
}
foreach {k v} $args {
if {$k ni $known_opts} {
error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'"
}
}
set opts [dict merge $default $args]
set backchar [dict get $opts -backchar]
set headchar [dict get $opts -headchar]
set tailchar [dict get $opts -tailchar]
set headoverridechar [dict get $opts -headoverridechar]
set tailoverridechar [dict get $opts -tailoverridechar]
set justify [dict get $opts -justify]
#----------------------------------------------------------------------------
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
#calculate headwidths
set headwidth 0
set tailwidth 0
foreach {key def} $colwidths {
set thisheadlen [string length [dict get $def head]]
if {$thisheadlen > $headwidth} {
set headwidth $thisheadlen
}
set thistaillen [string length [dict get $def tail]]
if {$thistaillen > $tailwidth} {
set tailwidth $thistaillen
}
}
set spec [dict get $colwidths $col]
if {[string length $backchar]} {
set ch $backchar
} else {
set ch [dict get $spec ch]
}
set num [dict get $spec num]
set headchar [dict get $spec head]
set tailchar [dict get $spec tail]
if {[string length $headchar]} {
set headchar $headchar
}
if {[string length $tailchar]} {
set tailchar $tailchar
}
#overrides only apply if the head/tail has a length
if {[string length $headchar]} {
if {[string length $headoverridechar]} {
set headchar $headoverridechar
}
}
if {[string length $tailchar]} {
if {[string length $tailoverridechar]} {
set tailchar $tailoverridechar
}
}
set head [string repeat $headchar $headwidth]
set tail [string repeat $tailchar $tailwidth]
set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]]
if {$justify eq "left"} {
set left_done [overtype::left $base "$head$val"]
return [overtype::right $left_done "$tail"]
} elseif {$justify in {centre center}} {
set mid_done [overtype::centre $base $val]
set left_mid_done [overtype::left $mid_done $head]
return [overtype::right $left_mid_done $tail]
} else {
set right_done [overtype::right $base "$val$tail"]
return [overtype::left $right_done $head]
}
}
}
}
}
#package require pattern
proc ::pattern::libs {} {
set libs [list \
pattern {-type core -note "alternative:pattern2"}\
pattern2 {-type core -note "alternative:pattern"}\
patterncmd {-type core}\
metaface {-type core}\
patternpredator2 {-type core}\
patterndispatcher {-type core}\
patternlib {-type core}\
patterncipher {-type optional -note optional}\
]
package require overtype
set result ""
append result "[cmd::util::colbreak lib]\n"
append result "[cmd::util::colhead lib -justify centre]\n"
append result "[cmd::util::colbreak lib]\n"
foreach libname [dict keys $libs] {
set libinfo [dict get $libs $libname]
append result [cmd::util::col lib library $libname]
if {[catch [list package present $libname] ver]} {
append result [cmd::util::col lib version "N/A"]
} else {
append result [cmd::util::col lib version $ver]
}
append result [cmd::util::col lib type [dict get $libinfo -type]]
if {[dict exists $libinfo -note]} {
set note [dict get $libinfo -note]
} else {
set note ""
}
append result [cmd::util::col lib note $note]
append result "\n"
}
append result "[cmd::util::colbreak lib]\n"
return $result
}
proc ::pattern::record {recname fields} {
if {[uplevel 1 [list namespace which $recname]] ne ""} {
error "(pattern::record) Can't create command '$recname': A command of that name already exists"
}
set index -1
set accessor [list ::apply {
{index rec args}
{
if {[llength $args] == 0} {
return [lindex $rec $index]
}
if {[llength $args] == 1} {
return [lreplace $rec $index $index [lindex $args 0]]
}
error "Invalid number of arguments."
}
}]
set map {}
foreach field $fields {
dict set map $field [linsert $accessor end [incr index]]
}
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec]
}
proc ::pattern::record2 {recname fields} {
if {[uplevel 1 [list namespace which $recname]] ne ""} {
error "(pattern::record) Can't create command '$recname': A command of that name already exists"
}
set index -1
set accessor [list ::apply]
set template {
{rec args}
{
if {[llength $args] == 0} {
return [lindex $rec %idx%]
}
if {[llength $args] == 1} {
return [lreplace $rec %idx% %idx% [lindex $args 0]]
}
error "Invalid number of arguments."
}
}
set map {}
foreach field $fields {
set body [string map [list %idx% [incr index]] $template]
dict set map $field [list ::apply $body]
}
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec]
}
proc ::argstest {args} {
package require cmdline
}
proc ::pattern::objects {} {
set result [::list]
foreach ns [namespace children ::pp] {
#lappend result [::list [namespace tail $ns] [set ${ns}::(self)]]
set ch [namespace tail $ns]
if {[string range $ch 0 2] eq "Obj"} {
set OID [string range $ch 3 end] ;#OID need not be digits (!?)
lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]]
}
}
return $result
}
proc ::pattern::name {num} {
#!todo - fix
#set ::p::${num}::(self)
lassign [interp alias {} ::p::$num] _predator info
if {![string length $_predator$info]} {
error "No object found for num:$num (no interp alias for ::p::$num)"
}
set invocants [dict get $info i]
set invocants_with_role_this [dict get $invocants this]
set invocant_this [lindex $invocants_with_role_this 0]
#lassign $invocant_this id info
#set map [dict get $info map]
#set fields [lindex $map 0]
lassign $invocant_this _id _ns _defaultmethod name _etc
return $name
}
proc ::pattern::with {cmd script} {
foreach c [info commands ::p::-1::*] {
interp alias {} [namespace tail $c] {} $c $cmd
}
interp alias {} . {} $cmd .
interp alias {} .. {} $cmd ..
return [uplevel 1 $script]
}
#system diagnostics etc
proc ::pattern::varspace_list {IID} {
namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables
set varspaces [list]
dict for {vname vdef} $o_variables {
set vs [dict get $vdef varspace]
if {$vs ni $varspaces} {
lappend varspaces $vs
}
}
if {$o_varspace ni $varspaces} {
lappend varspaces $o_varspace
}
return $varspaces
}
proc ::pattern::check_interfaces {} {
foreach ns [namespace children ::p] {
set IID [namespace tail $ns]
if {[string is digit $IID]} {
foreach ref [array names ${ns}::_iface::o_usedby] {
set OID [string range $ref 1 end]
if {![namespace exists ::p::${OID}::_iface]} {
puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n"
} else {
puts -nonewline stdout .
}
#if {![info exists ::p::${OID}::(self)]} {
# puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID"
#}
}
}
}
puts -nonewline stdout "\r\n"
}
#from: http://wiki.tcl.tk/8766 (Introspection on aliases)
#usedby: metaface-1.1.6+
#required because aliases can be renamed.
#A renamed alias will still return it's target with 'interp alias {} oldname'
# - so given newname - we require which_alias to return the same info.
proc ::pattern::which_alias {cmd} {
uplevel 1 [list ::trace add execution $cmd enterstep ::error]
catch {uplevel 1 $cmd} res
uplevel 1 [list ::trace remove execution $cmd enterstep ::error]
#puts stdout "which_alias $cmd returning '$res'"
return $res
}
# [info args] like proc following an alias recursivly until it reaches
# the proc it originates from or cannot determine it.
# accounts for default parameters set by interp alias
#
proc ::pattern::aliasargs {cmd} {
set orig $cmd
set defaultargs [list]
# loop until error or return occurs
while {1} {
# is it a proc already?
if {[string equal [info procs $cmd] $cmd]} {
set result [info args $cmd]
# strip off the interp set default args
return [lrange $result [llength $defaultargs] end]
}
# is it a built in or extension command we can get no args for?
if {![string equal [info commands $cmd] $cmd]} {
error "\"$orig\" isn't a procedure"
}
# catch bogus cmd names
if {[lsearch [interp aliases {}] $cmd]==-1} {
if {[catch {::pattern::which_alias $cmd} alias]} {
error "\"$orig\" isn't a procedure or alias or command"
}
#set cmd [lindex $alias 0]
if {[llength $alias]>1} {
set cmd [lindex $alias 0]
set defaultargs [concat [lrange $alias 1 end] $defaultargs]
} else {
set cmd $alias
}
} else {
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} {
# check if it is aliased in from another interpreter
if {[catch {interp target {} $cmd} msg]} {
error "Cannot resolve \"$orig\", alias leads to another interpreter."
}
if {$msg != {} } {
error "Not recursing into slave interpreter \"$msg\".\
\"$orig\" could not be resolved."
}
# check if defaults are set for the alias
if {[llength $cmdargs]>1} {
set cmd [lindex $cmdargs 0]
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs]
} else {
set cmd $cmdargs
}
}
}
}
}
proc ::pattern::aliasbody {cmd} {
set orig $cmd
set defaultargs [list]
# loop until error or return occurs
while {1} {
# is it a proc already?
if {[string equal [info procs $cmd] $cmd]} {
set result [info body $cmd]
# strip off the interp set default args
return $result
#return [lrange $result [llength $defaultargs] end]
}
# is it a built in or extension command we can get no args for?
if {![string equal [info commands $cmd] $cmd]} {
error "\"$orig\" isn't a procedure"
}
# catch bogus cmd names
if {[lsearch [interp aliases {}] $cmd]==-1} {
if {[catch {::pattern::which_alias $cmd} alias]} {
error "\"$orig\" isn't a procedure or alias or command"
}
#set cmd [lindex $alias 0]
if {[llength $alias]>1} {
set cmd [lindex $alias 0]
set defaultargs [concat [lrange $alias 1 end] $defaultargs]
} else {
set cmd $alias
}
} else {
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} {
# check if it is aliased in from another interpreter
if {[catch {interp target {} $cmd} msg]} {
error "Cannot resolve \"$orig\", alias leads to another interpreter."
}
if {$msg != {} } {
error "Not recursing into slave interpreter \"$msg\".\
\"$orig\" could not be resolved."
}
# check if defaults are set for the alias
if {[llength $cmdargs]>1} {
set cmd [lindex $cmdargs 0]
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs]
} else {
set cmd $cmdargs
}
}
}
}
}
proc ::pattern::uniqueKey2 {} {
#!todo - something else??
return [clock seconds]-[incr ::pattern::idCounter]
}
#used by patternlib package
proc ::pattern::uniqueKey {} {
return [incr ::pattern::idCounter]
#uuid with tcllibc is about 30us compared with 2us
# for large datasets, e.g about 100K inserts this would be pretty noticable!
#!todo - uuid pool with background thread to repopulate when idle?
#return [uuid::uuid generate]
}
#-------------------------------------------------------------------------------------------------------------------------
proc ::pattern::test1 {} {
set msg "OK"
puts stderr "next line should say:'--- saystuff:$msg"
::>pattern .. Create ::>thing
::>thing .. PatternMethod saystuff args {
puts stderr "--- saystuff: $args"
}
::>thing .. Create ::>jjj
::>jjj . saystuff $msg
::>jjj .. Destroy
::>thing .. Destroy
}
proc ::pattern::test2 {} {
set msg "OK"
puts stderr "next line should say:'--- property 'stuff' value:$msg"
::>pattern .. Create ::>thing
::>thing .. PatternProperty stuff $msg
::>thing .. Create ::>jjj
puts stderr "--- property 'stuff' value:[::>jjj . stuff]"
::>jjj .. Destroy
::>thing .. Destroy
}
proc ::pattern::test3 {} {
set msg "OK"
puts stderr "next line should say:'--- property 'stuff' value:$msg"
::>pattern .. Create ::>thing
::>thing .. Property stuff $msg
puts stderr "--- property 'stuff' value:[::>thing . stuff]"
::>thing .. Destroy
}
#---------------------------------
#unknown/obsolete
#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args}
if {0} {
proc ::p::internals::new_interface {{usedbylist {}}} {
set OID [incr ::p::ID]
::p::internals::new_object ::p::ifaces::>$OID "" $OID
puts "obsolete >> new_interface created object $OID"
foreach usedby $usedbylist {
set ::p::${OID}::_iface::o_usedby(i$usedby) 1
}
set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace)
#NOTE - o_varspace is only the default varspace for when new methods/properties are added.
# it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value.
set ::p::${OID}::_iface::o_constructor [list]
set ::p::${OID}::_iface::o_variables [list]
set ::p::${OID}::_iface::o_properties [dict create]
set ::p::${OID}::_iface::o_methods [dict create]
array set ::p::${OID}::_iface::o_definition [list]
set ::p::${OID}::_iface::o_open 1 ;#open for extending
return $OID
}
#temporary way to get OID - assumes single 'this' invocant
#!todo - make generic.
proc ::pattern::get_oid {_ID_} {
#puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]"
return [lindex [dict get $_ID_ i this] 0 0]
#set invocants [dict get $_ID_ i]
#set invocant_roles [dict keys $invocants]
#set role_members [dict get $invocants this]
##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list.
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;
#lassign $this_invocant OID this_info
#
#return $OID
}
#compile the uncompiled level1 interface
#assert: no more than one uncompiled interface present at level1
proc ::p::meta::PatternCompile {self} {
error "PatternCompile ????"
upvar #0 $self SELFMAP
set ID [lindex $SELFMAP 0 0]
set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces
set iid -1
foreach i $patterns {
if {[set ::p::${i}::_iface::o_open]} {
set iid $i ;#found it
break
}
}
if {$iid > -1} {
#!todo
::p::compile_interface $iid
set ::p::${iid}::_iface::o_open 0
} else {
#no uncompiled interface present at level 1. Do nothing.
return
}
}
proc ::p::meta::Def {self} {
error ::p::meta::Def
upvar #0 $self SELFMAP
set self_ID [lindex $SELFMAP 0 0]
set IFID [lindex $SELFMAP 1 0 end]
set maxc1 0
set maxc2 0
set arrName ::p::${IFID}::
upvar #0 $arrName state
array set methods {}
foreach nm [array names state] {
if {[regexp {^m-1,name,(.+)} $nm _match mname]} {
set methods($mname) [set state($nm)]
if {[string length $mname] > $maxc1} {
set maxc1 [string length $mname]
}
if {[string length [set state($nm)]] > $maxc2} {
set maxc2 [string length [set state($nm)]]
}
}
}
set bg1 [string repeat " " [expr {$maxc1 + 2}]]
set bg2 [string repeat " " [expr {$maxc2 + 2}]]
set r {}
foreach nm [lsort -dictionary [array names methods]] {
set arglist $state(m-1,args,$nm)
append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n"
}
return $r
}
}

2588
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternlib-1.2.8.tm

File diff suppressed because it is too large Load Diff

755
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternpredator2-1.2.8.tm

@ -0,0 +1,755 @@
proc ::p::internals::jaws {OID _ID_ args} {
#puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args"
#set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
yield
set w 1
set stack [list]
set wordcount [llength $args]
set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first
set unsupported 0
set operator ""
set operator_prev "" ;#used only by argprotect to revert to previous operator
if {$OID ne "null"} {
#!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!)
#upvar #0 ::p::${OID}::_meta::map MAP
set MAP [set ::p::${OID}::_meta::map]
} else {
# error "jaws - OID = 'null' ???"
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key
}
set invocantdata [dict get $MAP invocantdata]
lassign $invocantdata OID alias default_method object_command wrapped
set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code
#don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w
while {$w < $wordcount} {
set word [lindex $args [expr {$w -1}]]
#puts stdout "w:$w word:$word stack:$stack"
if {$operator eq "argprotect"} {
set operator $operator_prev
lappend stack $word
incr w
} else {
if {[llength $stack]} {
if {$word in $terminals} {
set reduction [list 0 $_ID_ {*}$stack ]
#puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w"
set _ID_ [yield $reduction]
set stack [list]
#set OID [::pattern::get_oid $_ID_]
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
if {$OID ne "null"} {
set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here!
} else {
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]]
#puts stderr "WARNING REVIEW: jaws-branch - leave empty??????"
}
#review - 2018. switched to _ID_ instead of MAP
lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command
#lassign [dict get $MAP invocantdata] OID alias default_method object_command
#puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command"
set operator $word
#don't incr w
#incr w
} else {
if {$operator eq "argprotect"} {
set operator $operator_prev
set operator_prev ""
lappend stack $word
} else {
#only look for leading argprotect chacter (-) if we're not already in argprotect mode
if {$word eq "--"} {
set operator_prev $operator
set operator "argprotect"
#Don't add the plain argprotector to the stack
} elseif {[string match "-*" $word]} {
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument)
set operator_prev $operator
set operator "argprotect"
lappend stack $word
} else {
lappend stack $word
}
}
incr w
}
} else {
#no stack
switch -- $word {.} {
if {$OID ne "null"} {
#we know next word is a property or method of a pattern object
incr w
set nextword [lindex $args [expr {$w - 1}]]
set command ::p::${OID}::$nextword
set stack [list $command] ;#2018 j
set operator .
if {$w eq $wordcount} {
set finished_args 1
}
} else {
# don't incr w
#set nextword [lindex $args [expr {$w - 1}]]
set command $object_command ;#taken from the MAP
set stack [list "_exec_" $command]
set operator .
}
} {..} {
incr w
set nextword [lindex $args [expr {$w -1}]]
set command ::p::-1::$nextword
#lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list.
set stack [list $command] ;#faster, and intent is clearer than lappend.
set operator ..
if {$w eq $wordcount} {
set finished_args 1
}
} {,} {
#puts stdout "Stackless comma!"
if {$OID ne "null"} {
set command ::p::${OID}::$default_method
} else {
set command [list $default_method $object_command]
#object_command in this instance presumably be a list and $default_method a list operation
#e.g "lindex {A B C}"
}
#lappend stack $command
set stack [list $command]
set operator ,
} {--} {
set operator_prev $operator
set operator argprotect
#no stack -
} {!} {
set command $object_command
set stack [list "_exec_" $object_command]
#puts stdout "!!!! !!!! $stack"
set operator !
} default {
if {$operator eq ""} {
if {$OID ne "null"} {
set command ::p::${OID}::$default_method
} else {
set command [list $default_method $object_command]
}
set stack [list $command]
set operator ,
lappend stack $word
} else {
#no stack - so we don't expect to be in argprotect mode already.
if {[string match "-*" $word]} {
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument)
set operator_prev $operator
set operator "argprotect"
lappend stack $word
} else {
lappend stack $word
}
}
}
incr w
}
}
} ;#end while
#process final word outside of loop
#assert $w == $wordcount
#trailing operators or last argument
if {!$finished_args} {
set word [lindex $args [expr {$w -1}]]
if {$operator eq "argprotect"} {
set operator $operator_prev
set operator_prev ""
lappend stack $word
incr w
} else {
switch -- $word {.} {
if {![llength $stack]} {
#set stack [list "_result_" [::p::internals::ref_to_object $_ID_]]
yieldto return [::p::internals::ref_to_object $_ID_]
error "assert: never gets here"
} else {
#puts stdout "==== $stack"
#assert - whenever _ID_ changed in this proc - we have updated the $OID variable
yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack]
error "assert: never gets here"
}
set operator .
} {..} {
#trailing .. after chained call e.g >x . item 0 ..
#puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$"
#set reduction [list 0 $_ID_ {*}$stack]
yieldto return [yield [list 0 $_ID_ {*}$stack]]
} {#} {
set unsupported 1
} {,} {
set unsupported 1
} {&} {
set unsupported 1
} {@} {
set unsupported 1
} {--} {
#set reduction [list 0 $_ID_ {*}$stack[set stack [list]]]
#puts stdout " -> -> -> about to call yield $reduction <- <- <-"
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ]
#set OID [::pattern::get_oid $_ID_]
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
if {$OID ne "null"} {
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here!
} else {
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ]
}
yieldto return $MAP
} {!} {
#error "untested branch"
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]]
#set OID [::pattern::get_oid $_ID_]
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
if {$OID ne "null"} {
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here!
} else {
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ]
}
lassign [dict get $MAP invocantdata] OID alias default_command object_command
set command $object_command
set stack [list "_exec_" $command]
set operator !
} default {
if {$operator eq ""} {
#error "untested branch"
lassign [dict get $MAP invocantdata] OID alias default_command object_command
#set command ::p::${OID}::item
set command ::p::${OID}::$default_command
lappend stack $command
set operator ,
}
#do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway.
lappend stack $word
}
if {$unsupported} {
set unsupported 0
error "trailing '$word' not supported"
}
#if {$operator eq ","} {
# incr wordcount 2
# set stack [linsert $stack end-1 . item]
#}
incr w
}
}
#final = 1
#puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]"
return [list 1 $_ID_ {*}$stack]
}
#trailing. directly after object
proc ::p::internals::ref_to_object {_ID_} {
set OID [lindex [dict get $_ID_ i this] 0 0]
upvar #0 ::p::${OID}::_meta::map MAP
lassign [dict get $MAP invocantdata] OID alias default_method object_command
set refname ::p::${OID}::_ref::__OBJECT
array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_]
if {[list {read} $traceCmd] ni [trace info variable $refname]} {
#puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'"
trace add variable $refname {read} $traceCmd
}
set traceCmd [list ::p::predator::object_array_trace $OID $_ID_]
if {[list {array} $traceCmd] ni [trace info variable $refname]} {
trace add variable $refname {array} $traceCmd
}
set traceCmd [list ::p::predator::object_write_trace $OID $_ID_]
if {[list {write} $traceCmd] ni [trace info variable $refname]} {
trace add variable $refname {write} $traceCmd
}
set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_]
if {[list {unset} $traceCmd] ni [trace info variable $refname]} {
trace add variable $refname {unset} $traceCmd
}
return $refname
}
proc ::p::internals::create_or_update_reference {OID _ID_ refname command} {
#if {[lindex $fullstack 0] eq "_exec_"} {
# #strip it. This instruction isn't relevant for a reference.
# set commandstack [lrange $fullstack 1 end]
#} else {
# set commandstack $fullstack
#}
#set argstack [lassign $commandstack command]
#set field [string map {> __OBJECT_} [namespace tail $command]]
set reftail [namespace tail $refname]
set argstack [lassign [split $reftail +] field]
set field [string map {> __OBJECT_} [namespace tail $command]]
#puts stderr "refname:'$refname' command: $command field:$field"
if {$OID ne "null"} {
upvar #0 ::p::${OID}::_meta::map MAP
} else {
#set map [dict get [lindex [dict get $_ID_ i this] 0 1] map]
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}]
}
lassign [dict get $MAP invocantdata] OID alias default_method object_command
if {$OID ne "null"} {
interp alias {} $refname {} $command $_ID_ {*}$argstack
} else {
interp alias {} $refname {} $command {*}$argstack
}
#set iflist [lindex $map 1 0]
set iflist [dict get $MAP interfaces level0]
#set iflist [dict get $MAP interfaces level0]
set field_is_property_like 0
foreach IFID [lreverse $iflist] {
#tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient.
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} {
set field_is_property_like 1
#There is a setter or getter (but not necessarily an entry in the o_properties dict)
break
}
}
#whether field is a property or a method - remove any commandrefMisuse_TraceHandler
foreach tinfo [trace info variable $refname] {
#puts "-->removing traces on $refname: $tinfo"
if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} {
trace remove variable $refname {*}$tinfo
}
}
if {$field_is_property_like} {
#property reference
set this_invocantdata [lindex [dict get $_ID_ i this] 0]
lassign $this_invocantdata OID _alias _defaultmethod object_command
#get fully qualified varspace
#
set propdict [$object_command .. GetPropertyInfo $field]
if {[dict exists $propdict $field]} {
set field_is_a_property 1
set propinfo [dict get $propdict $field]
set varspace [dict get $propinfo varspace]
if {$varspace eq ""} {
set full_varspace ::p::${OID}
} else {
if {[::string match "::*" $varspace]} {
set full_varspace $varspace
} else {
set full_varspace ::p::${OID}::$varspace
}
}
} else {
set field_is_a_property 0
#no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property
#this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later)
set full_varspace ::p::${OID}
}
#We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first))
set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field]
if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} {
trace add variable ${full_varspace}::o_${field} {write} $Hndlr
}
set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field]
if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} {
trace add variable ${full_varspace}::o_${field} {unset} $Hndlr
}
#supply all data in easy-access form so that propref_trace_read is not doing any extra work.
set get_cmd ::p::${OID}::(GET)$field
set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack]
if {[list {read} $traceCmd] ni [trace info variable $refname]} {
set fieldvarname ${full_varspace}::o_${field}
#synch the refvar with the real var if it exists
#catch {set $refname [$refname]}
if {[array exists $fieldvarname]} {
if {![llength $argstack]} {
#unindexed reference
array set $refname [array get $fieldvarname]
#upvar $fieldvarname $refname
} else {
set s0 [lindex $argstack 0]
#refs to nonexistant array members common? (catch vs 'info exists')
if {[info exists ${fieldvarname}($s0)]} {
set $refname [set ${fieldvarname}($s0)]
}
}
} else {
#refs to uninitialised props actually should be *very* common.
#If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive.
#Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch.
#set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches!
#puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------"
if {![llength $argstack]} {
#catch {set $refname [set ::p::${OID}::o_$field]}
if {[info exists $fieldvarname]} {
set $refname [set $fieldvarname]
#upvar $fieldvarname $refname
}
} else {
if {[llength $argstack] == 1} {
#catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]}
if {[info exists $fieldvarname]} {
set $refname [lindex [set $fieldvarname] [lindex $argstack 0]]
}
} else {
#catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]}
if {[info exists $fieldvarname]} {
set $refname [lindex [set $fieldvarname] $argstack]
}
}
}
#! what if someone has put a trace on ::errorInfo??
#set ::errorInfo $errorInfo_prev
}
trace add variable $refname {read} $traceCmd
set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname]
trace add variable $refname {write} $traceCmd
set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname]
trace add variable $refname {unset} $traceCmd
set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname]
# puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd"
trace add variable $refname {array} $traceCmd
}
} else {
#puts "$refname ====> adding refMisuse_traceHandler $alias $field"
#matching variable in order to detect attempted use as property and throw error
# 2018
#Note that we are adding a trace on a variable (the refname) which does not exist.
#this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex)
#we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added
##array set $refname {} ;#empty array
# - the empty array would mean a slightly better error message when misusing a command ref as an array
#but this seems like a code complication for little benefit
#review
trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field]
}
}
#trailing. after command/property
proc ::p::internals::ref_to_stack {OID _ID_ fullstack} {
if {[lindex $fullstack 0] eq "_exec_"} {
#strip it. This instruction isn't relevant for a reference.
set commandstack [lrange $fullstack 1 end]
} else {
set commandstack $fullstack
}
set argstack [lassign $commandstack command]
set field [string map {> __OBJECT_} [namespace tail $command]]
#!todo?
# - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace.
# - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted.
#references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself.
# - this would in theory allow a set of interface functions on the object which have direct access to the reference variables.
set refname ::p::${OID}::_ref::[join [concat $field $argstack] +]
if {[llength [info commands $refname]]} {
#todo - review - what if the field changed to/from a property/method?
#probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs
return $refname
}
::p::internals::create_or_update_reference $OID $_ID_ $refname $command
return $refname
}
namespace eval pp {
variable operators [list .. . -- - & @ # , !]
variable operators_notin_args ""
foreach op $operators {
append operators_notin_args "({$op} ni \$args) && "
}
set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands
#set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)}
}
interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks!
# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism.
#each map is a 2 element list of lists.
# form: {$commandinfo $interfaceinfo}
# commandinfo is of the form: {ID Namespace defaultmethod commandname _?}
#2018
#each map is a dict.
#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}}
#OID = Object ID (integer for now - could in future be a uuid)
proc ::p::predator2 {_ID_ args} {
#puts stderr "predator2: _ID_:'$_ID_' args:'$args'"
#set invocants [dict get $_ID_ i]
#set invocant_roles [dict keys $invocants]
#For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc.
#set this_role_members [dict get $invocants this]
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list.
#lassign $this_invocant this_OID this_info_dict
set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
set cheat 1 ;#
#-------
#Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call)
#(it should be functionally equivalent to remove this shortcut block)
if {$cheat} {
if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} {
set remaining_args [lassign $args dot method_or_prop]
#how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ???
set command ::p::${this_OID}::$method_or_prop
#REVIEW!
#e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say')
#if {[llength $command] > 1} {
# error "methods with spaces not included in test suites - todo fix!"
#}
#Dont use {*}$command - (so we can support methods with spaces)
#if {![llength [info commands $command]]} {}
if {[namespace which $command] eq ""} {
if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} {
#lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces
set command ::p::${this_OID}::(UNKNOWN)
#tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
} else {
return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found"
}
} else {
#tailcall {*}$command $_ID_ {*}$remaining_args
tailcall $command $_ID_ {*}$remaining_args
}
}
}
#------------
if {([llength $args] == 1) && ([lindex $args 0] eq "..")} {
return $_ID_
}
#puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args"
#puts stderr "this_info_dict: $this_info_dict"
if {![llength $args]} {
#should return some sort of public info.. i.e probably not the ID which is an implementation detail
#return cmd
return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID
#return a dict keyed on object command name - (suitable as use for a .. Create 'target')
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped
#return [list $object_command [list -id $this_OID ]]
} elseif {[llength $args] == 1} {
#short-circuit the single index case for speed.
if {[lindex $args 0] ni {.. . -- - & @ # , !}} {
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method
lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method
tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0]
} elseif {[lindex $args 0] eq {--}} {
#!todo - we could hide the invocant by only allowing this call from certain uplevel procs..
# - combined with using UUIDs for $OID, and a secured/removed metaface on the object
# - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases)
# - this could effectively hide the object's namespaces,vars etc from the caller (?)
return [set ::p::${this_OID}::_meta::map]
}
}
#upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls)
#incr c
#set reduce ::p::reducer${this_OID}_$c
set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance]
#puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args"
coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args
set current_ID_ $_ID_
set final 0
set result ""
while {$final == 0} {
#the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws)
set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command]
#puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'"
#if {[string match *Destroy $command]} {
# puts stdout " calling Destroy reduction_args:'$reduction_args'"
#}
if {$final == 1} {
if {[llength $command] == 1} {
if {$command eq "_exec_"} {
tailcall {*}$reduction_args
}
if {[llength [info commands $command]]} {
tailcall {*}$command $current_ID_ {*}$reduction_args
}
set cmdname [namespace tail $command]
set this_OID [lindex [dict get $current_ID_ i this] 0 0]
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} {
lset command 0 ::p::${this_OID}::(UNKNOWN)
tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg.
} else {
return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found"
}
} else {
#e.g lindex {a b c}
tailcall {*}$command {*}$reduction_args
}
} else {
if {[lindex $command 0] eq "_exec_"} {
set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]]
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ]
} else {
if {[llength $command] == 1} {
if {![llength [info commands $command]]} {
set cmdname [namespace tail $command]
set this_OID [lindex [dict get $current_ID_ i this] 0 0]
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} {
lset command 0 ::p::${this_OID}::(UNKNOWN)
set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
} else {
return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found"
}
} else {
#set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]]
set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]]
}
} else {
set result [uplevel 1 [list {*}$command {*}$reduction_args]]
}
if {[llength [info commands $result]]} {
if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} {
#looks like a pattern command
set current_ID_ [$result .. INVOCANTDATA]
#todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA
#if {![catch {$result .. INVOCANTDATA} result_invocantdata]} {
# set current_ID_ $result_invocantdata
#} else {
# return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object"
#}
} else {
#non-pattern command
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}]
}
} else {
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}]
#!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists)
}
}
}
}
error "Assert: Shouldn't get here (end of ::p::predator2)"
#return $result
}
package provide patternpredator2 1.2.8

4
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm

@ -8122,10 +8122,10 @@ namespace eval punk {
interp alias {} mode {} punk::mode
proc aliases {{glob *}} {
tailcall punk::lib::aliases $glob
tailcall punk::ns::aliases $glob
}
proc alias {{aliasorglob ""} args} {
tailcall punk::lib::alias $aliasorglob {*}$args
tailcall punk::ns::alias $aliasorglob {*}$args
}

4
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm

@ -108,8 +108,6 @@ tcl::namespace::eval punk::aliascore {
# the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were.
set aliases [tcl::dict::create\
val ::punk::pipe::val\
aliases ::punk::lib::aliases\
alias ::punk::lib::alias\
tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\
@ -138,6 +136,8 @@ tcl::namespace::eval punk::aliascore {
config ::punk::config\
s ::punk::ns::synopsis\
eg ::punk::ns::eg\
aliases ::punk::ns::aliases\
alias ::punk::ns::alias\
]
#*** !doctools

19
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm

@ -147,14 +147,18 @@ tcl::namespace::eval punk::ansi::class {
}]
method render_to_input_line {args} {
if {[llength $args] < 1} {
puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args
#puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
#punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args
punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line"
return
}
set x [lindex $args end]
set arglist [lrange $args 0 end-1]
if {[llength $arglist] %2 != 0} {
puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args
#puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
#punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args
punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line"
return
}
set opts [tcl::dict::create\
-dimensions 80x24\
@ -6076,12 +6080,13 @@ tcl::namespace::eval punk::ansi::ta {
}
#perl: ta_strip
punk::args::set_alias ::punk::ansi::ta::strip ::punk::ansi::ansistrip
proc strip {text} {
#*** !doctools
#[call [fun strip] [arg text]]
#[para]Return text stripped of Ansi codes
#[para]This is a tailcall to punk::ansi::ansistrip
tailcall ansistrip $text
tailcall punk::ansi::ansistrip $text
}
lappend PUNKARGS [list {
@ -6113,7 +6118,7 @@ tcl::namespace::eval punk::ansi::ta {
"Calculate length of text (excluding the ANSI codes)
This is not the printing length of the string on screen."
@values -min 1
text -type string
text -type string
} ]
#perl: ta_length
proc length {text} {
@ -6133,7 +6138,7 @@ tcl::namespace::eval punk::ansi::ta {
#perl: ta_trunc
#truncate $text to $width columns while still including all the ANSI colour codes.
proc trunc {text width args} {
error "unimplemented"
}
#not in perl ta

4
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm

@ -1,6 +1,6 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_::punk::ansi::colourmap 0 0.1.0]
#[manpage_begin punkshell_module_::punk::ansi::colourmap 0 0.1.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]

194
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm

@ -257,7 +257,7 @@ tcl::namespace::eval punk::args::register {
if {![info exists scanned_info]} {
set scanned_info [dict create]
}
#some packages, e.g punk::args::tclcore document other namespaces.
#some packages, e.g punk::args::moduledoc::tclcore document other namespaces.
#when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources
variable namespace_docpackages
if {![info exists namespace_docpackages]} {
@ -466,6 +466,8 @@ tcl::namespace::eval punk::args {
recognised types:
any
(unvalidated - accepts anything)
unknown
(unvalidated - accepts anything)
none
(used for flags/switches only. Indicates this is
a 'solo' flag ie accepts no value)
@ -475,6 +477,8 @@ tcl::namespace::eval punk::args {
number
list
indexexpression
indexset
(as accepted by punk::lib::is_indexset)
dict
double
float
@ -632,7 +636,7 @@ tcl::namespace::eval punk::args {
from existing definitions (by id) for re-use of argument specifications and help text)
e.g the following definition passes 2 blocks as text arguments
${[punk::args::tclcore::argdoc::example {
${[punk::args::moduledoc::tclcore::argdoc::example {
punk::args::define {
@id -id ::myns::myfunc
@cmd -name myns::myfunc -help\
@ -764,24 +768,25 @@ tcl::namespace::eval punk::args {
if {[dict exists $rawdef_cache $args]} {
return [dict get [dict get $rawdef_cache $args] -id]
} else {
set id [rawdef_id $args]
set lvl 2
set id [rawdef_id $args $lvl]
if {[id_exists $id]} {
#we seem to be re-creating a previously defined id...
#clear any existing caches for this id
puts stderr "punk::args::define Redefinition of id:$id - clearing existing data"
undefine $id 0
#dict unset argdata_cache $prevraw ;#silently does nothing if key not present
dict for {k v} $argdata_cache {
if {[dict get $v id] eq $id} {
dict unset argdata_cache $k
}
}
dict for {k v} $rawdef_cache {
if {[dict get $v -id] eq $id} {
dict unset rawdef_cache $k
}
}
dict unset id_cache_rawdef $id
##dict unset argdata_cache $prevraw ;#silently does nothing if key not present
#dict for {k v} $argdata_cache {
# if {[dict get $v id] eq $id} {
# dict unset argdata_cache $k
# }
#}
#dict for {k v} $rawdef_cache {
# if {[dict get $v -id] eq $id} {
# dict unset rawdef_cache $k
# }
#}
#dict unset id_cache_rawdef $id
}
set is_dynamic [rawdef_is_dynamic $args]
set defspace [uplevel 1 {::namespace current}]
@ -790,6 +795,35 @@ tcl::namespace::eval punk::args {
return $id
}
}
proc undefine {id {quiet 0}} {
variable rawdef_cache
variable id_cache_rawdef
variable argdata_cache
if {[id_exists $id]} {
if {!$quiet} {
puts stderr "punk::args::undefine clearing existing data for id:$id"
}
dict for {k v} $argdata_cache {
if {[dict get $v id] eq $id} {
dict unset argdata_cache $k
}
}
dict for {k v} $rawdef_cache {
if {[dict get $v -id] eq $id} {
dict unset rawdef_cache $k
}
}
dict unset id_cache_rawdef $id
} else {
if {!$quiet} {
puts stderr "punk::args::undefine unable to find id: '$id'"
}
}
}
#'punk::args::parse $args withdef $deflist' can raise parsing error after an autoid was generated
# In this case we don't see the autoid in order to delete it
#proc undefine_deflist {deflist} {
#}
proc idquery_info {id} {
variable id_cache_rawdef
@ -889,7 +923,8 @@ tcl::namespace::eval punk::args {
set textargs $args
if {![llength $args]} {
punk::args::get_by_id ::punk::args::define {}
#punk::args::get_by_id ::punk::args::define {}
punk::args::parse {} -errorstyle minimal withid ::punk::args::define
return
}
#if {[lindex $args 0] eq "-dynamic"} {
@ -1184,7 +1219,7 @@ tcl::namespace::eval punk::args {
}
ref {
#a reference within the definition
#e.g see punk::args::tclcore ::after
#e.g see punk::args::moduledoc::tclcore ::after
#global reference dict - independent of forms
#ignore refs without an -id
#store all keys except -id
@ -1952,6 +1987,7 @@ tcl::namespace::eval punk::args {
char - character {set normtype char}
dict - dictionary {set normtype dict}
index - indexexpression {set normtype indexexpression}
indexset {set normtype indexset}
"" - none - solo {
if {$is_opt} {
#review - are we allowing clauses for flags?
@ -1975,6 +2011,10 @@ tcl::namespace::eval punk::args {
}
}
any - anything {set normtype any}
unknown {
#'unspecified' ??
set normtype unknown
}
ansi - ansistring {set normtype ansistring}
string - globstring {set normtype $lc_firstword}
literal {
@ -2705,25 +2745,38 @@ tcl::namespace::eval punk::args {
#@dynamic only has meaning as 1st element of a def in the deflist
}
#@id must be within first 4 lines of a block - or assign auto
#@id must be within first 4 lines of first 3 blocks - or assign auto
#review - @dynamic block where -id not explicitly set? - disallow?
proc rawdef_id {rawdef} {
proc rawdef_id {rawdef {lvl 1}} {
set id ""
foreach d $rawdef {
set found_id_line 0
foreach d [lrange $rawdef 0 2] {
foreach ln [lrange [split $d \n] 0 4] {
if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} {
if {$firstword eq "@id"} {
set found_id_line 1
#review - uplevel 2 would be a call from punk::args::define ??
set rest [uplevel $lvl [list punk::args::lib::tstr -allowcommands $rest]]
if {[llength $rest] %2 == 0 && [dict exists $rest -id]} {
set id [dict get $rest -id]
break
}
break
}
}
}
if {$id ne ""} {
if {$found_id_line} {
break
}
}
if {$id eq "" && $found_id_line} {
#Looked like an @id - but presumable the rest of the line was malformed.
#we won't produce an autoid for such a definition.
set first3blocks ""
foreach b [lrange $rawdef 0 2] {
append first3blocks $b\n
}
error "punk::args::rawdef_id found an @id line in the first 4 lines of one of the 1st 3 blocks - but failed to retrieve a value for it.\nraw_def 1st 3 blocks:\n$first3blocks"
}
if {$id eq "" || [string tolower $id] eq "auto"} {
variable id_counter
set id "autoid_[incr id_counter]"
@ -2916,7 +2969,9 @@ tcl::namespace::eval punk::args {
set seen_documentedns [list] ;#seen per pkgns
foreach definitionlist [set ${pkgns}::PUNKARGS] {
#namespace eval $evalns [list punk::args::define {*}$definitionlist]
set id [rawdef_id $definitionlist]
#set id [rawdef_id $definitionlist]
set lvl 1 ;#level at which tstr substitution occurs in @id line
set id [namespace eval $pkgns [list punk::args::rawdef_id $definitionlist $lvl]]
if {[string match autoid_* $id]} {
puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping"
puts stderr "definition:\n"
@ -2958,6 +3013,9 @@ tcl::namespace::eval punk::args {
} else {
set needed [list]
foreach pkgns $nslist {
if {[string match (autodef)* $pkgns]} {
set pkgns [string range $pkgns 9 end]
}
if {![string match ::* $pkgns]} {
puts stderr "warning: update_definitions received unqualified ns: $pkgns"
set pkgns ::$pkgns
@ -3443,18 +3501,28 @@ tcl::namespace::eval punk::args {
set docname [Dict_getdef $spec_dict doc_info -name "Manual:"]
set docurl [Dict_getdef $spec_dict doc_info -url ""]
#set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""]
#set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""]
#if {"$argdisplay_header$argdisplay_body" eq ""} {
# set is_custom_argdisplay 0
#} else {
# set is_custom_argdisplay 1
#}
#temp - TODO
#review - when can there be more than one selected form?
set argdisplay_header ""
set argdisplay_body ""
set is_custom_argdisplay 0
if {[llength $selected_forms] == 1} {
set fid [lindex $selected_forms 0]
set FRM [dict get $spec_dict FORMS $fid]
if {[dict size [dict get $FRM FORMDISPLAY]]} {
set argdisplay_header [Dict_getdef $FRM FORMDISPLAY -header ""]
set argdisplay_body [Dict_getdef $FRM FORMDISPLAY -body ""]
}
}
# if {![dict size $F $fid $FORMDISPLAY]} {}
#set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""]
#set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""]
if {"$argdisplay_header$argdisplay_body" eq ""} {
set is_custom_argdisplay 0
} else {
set is_custom_argdisplay 1
}
#set is_custom_argdisplay 0
set blank_header_col [list]
@ -4335,7 +4403,7 @@ tcl::namespace::eval punk::args {
documentation generated dynamically and may not yet have an id.
IDs for autogenenerated help are prefixed e.g (autodef)::myensemble.
Generally punk::ns::arginfo (aliased as i in the punk shell) should
Generally punk::ns::cmdhelp (aliased as i in the punk shell) should
be used in preference - as it will search for a documentation
mechanism and call punk::args::usage as necessary.
"
@ -5730,6 +5798,15 @@ tcl::namespace::eval punk::args {
break
}
}
indexset {
if {![punk::lib::is_indexset $e_check]} {
set msg "$argclass $argname for %caller% requires type indexset. A comma-delimited set of indexes or index-ranges separated by '..' Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
} else {
lset clause_results $c_idx $a_idx 1
break
}
}
string - ansistring - globstring {
#we may commonly want exceptions that ignore validation rules - most commonly probably the empty string
#we possibly don't want to always have to regex on things that don't pass the other more basic checks
@ -8729,7 +8806,7 @@ tcl::namespace::eval punk::args {
}
set type_expression [string trim $typespec ?]
if {$type_expression in {any none}} {
if {$type_expression in {any none unknown}} {
continue
}
#puts "$argname - switch on type_expression: $type_expression v:[lindex $vlist $clausecolumn]"
@ -8790,7 +8867,8 @@ tcl::namespace::eval punk::args {
dict set finalopts $o $v
}
}
return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived]
set docid [dict get $argspecs id]
return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived id $docid]
}
lappend PUNKARGS [list {
@ -9570,8 +9648,15 @@ tcl::namespace::eval punk::args {
}
}
set cinfo [punk::ns::resolve_command {*}$cmd]
set tp [dict get $cinfo cmdtype]
#don't use full cmdinfo if $cmd is a single element
if {[llength $cmd] == 1} {
set cinfo [punk::ns::cmdwhich $cmd]
set tp [dict get $cinfo whichtype]
} else {
puts stderr "WARNING ==ensemble_subcommands_definition== cmdinfo $cmd\n$cinfo"
set cinfo [punk::ns::cmdinfo {*}$cmd]
set tp [dict get $cinfo cmdtype]
}
dict set choiceinfodict $sc [list [list resolved $cmd]]
@ -9584,9 +9669,23 @@ tcl::namespace::eval punk::args {
}
}
if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} {
#could be more than one punk::args id - choose a precedence by how we order the id_exists checks.
if {[punk::args::id_exists [list $ensemble $sc]]} {
dict lappend choiceinfodict $sc {doctype punkargs}
dict lappend choiceinfodict $sc [list subhelp {*}$ensemble $sc]
} elseif {[punk::args::id_exists $cmd]} {
dict lappend choiceinfodict $sc {doctype punkargs}
dict lappend choiceinfodict $sc [list subhelp {*}$cmd]
} elseif {[punk::args::id_exists [dict get $cinfo origin]]} {
dict lappend choiceinfodict $sc {doctype punkargs}
dict lappend choiceinfodict $sc [list subhelp {*}[dict get $cinfo origin]]
} else {
#puts stderr "ensemble_subcommands_definition--- NO doc for [list $ensemble $sc] or $cmd or [dict get $cinfo origin]"
}
#if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} {
# dict lappend choiceinfodict $sc {doctype punkargs}
#}
}
set argdef ""
@ -9699,9 +9798,18 @@ tcl::namespace::eval punk::args::lib {
ooc {
lappend marks [punk::ns::Cmark ooc cyan]
}
classmethod {
lappend marks [punk::ns::Cmark classmethod term-orange1]
}
coremethod {
lappend marks [punk::ns::Cmark coremethod term-plum1]
}
ooo {
lappend marks [punk::ns::Cmark ooo cyan]
}
objectmethod {
lappend marks [punk::ns::Cmark objectmethod term-orange1]
}
native {
lappend marks [punk::ns::Cmark native]
}
@ -9724,11 +9832,11 @@ tcl::namespace::eval punk::args::lib {
@id -id ::punk::args::lib::tstr
@cmd -name punk::args::lib::tstr\
-summary\
"Templating with \$\{$varName\}"\
"Templating with placeholders such as: \$\{$varName\}"\
-help\
"A rough equivalent of js template literals
"Roughly analogous to js template literals
Substitutions:
Placeholder Substitutions:
\$\{$varName\}
\$\{[myCommand]\}
(when -allowcommands flag is given)"

7031
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm

File diff suppressed because it is too large Load Diff

195
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm

@ -4988,7 +4988,8 @@ tcl::namespace::eval punk::args::tclcore {
obsolete {variable vdelete vinfo}
}\
-choiceinfo {
add {{doctype punkargs} {subhelp ::trace add}}
add {{doctype punkargs} {subhelp ::trace add}}
remove {{doctype punkargs} {subhelp ::trace remove}}
}
@values -min 0 -max 0
@ -4996,23 +4997,30 @@ tcl::namespace::eval punk::args::tclcore {
punk::args::define {
@id -id "::trace add"
@cmd -name "Built-in: trace add" -help\
""
@cmd -name "Built-in: trace add"\
-summary\
"Add a command, execution or variable trace."\
-help\
"Add a command, execution or variable trace."
@form -synopsis "trace add type name ops ?args?"
@leaders
type -choicegroups {
"" {command execution variable}
}\
-choiceinfo {
command {{doctype punkargs}}
execution {{doctype punkargs}}
command {{doctype punkargs} {subhelp ::trace add command}}
execution {{doctype punkargs} {subhelp ::trace add execution}}
variable {{doctype punkargs}}
}
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace add command"
@cmd -name "Built-in: trace add command" -help\
@cmd -name "Built-in: trace add command"\
-summary\
"Add command trace for operation(s): rename delete"\
-help\
"Arrange for commandPrefix to be executed (with additional arguments)
whenever command name is modified in one of the ways given by the list
ops. Name will be resolved using the usual namespace resolution rules
@ -5056,10 +5064,126 @@ tcl::namespace::eval punk::args::tclcore {
"
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace add variable"
@cmd -name "Built-in: trace add variable"\
-summary\
"Add variable trace for operation(s): array read write unset."\
-help\
"Arrange for commandPrefix to be executed whenever variable name is accessed
in one of the ways given by the list ops. Name may refer to a normal variable,
an element of an array, or to an array as a whole (i.e. name may be just the
name of an array, with no parenthesized index). If name refers to a whole
array, then commandPrefix is invoked whenever any element of the array is
manipulated. If the variable does not exist, it will be created but will not
be given a value, so it will be visible to namespace which queries, but not to
info exists queries."
name -type string -help\
"Name of variable"
# ---------------------------------------------------------------
ops -type list -choices {array read write unset} -choiceprefix 0\
-choicemultiple {1 4}\
-choicecolumns 1\
-choicelabels {
array\
" Invoke commandPrefix whenever the variable is accessed or
modified via the array command, provided that name is not a
scalar variable at the time that the array command is invoked.
If name is a scalar variable, the access via the array command
will not trigger the trace."
read\
" Invoke commandPrefix whenever the variable isread."
write\
" Invoke commandPrefix whenever the variable is written."
unset\
" Invoke commandPrefix whenever the variable is unset. Variables
can be unset explicitly with the unset command, or implicitly
when procedures return (all of their local variables are unset).
Variables are also unset when interpreters are deleted, but
traces will not be invoked because there is no interpreter in
which to execute them."
}\
-help\
"Indicates which operations are of interest."
commandPrefix -type string -help\
"When the trace triggers, three arguments are appended to commandPrefix
so that the actual command is as follows:
-----------------------------------------
commandPrefix name1 name2 op
-----------------------------------------
Name1 gives the name for the variable being accessed. This is not
necessarily the same as the name used in the trace add variable command:
the upvar command allows a procedure to reference a variable under a
different name. If the trace was originally set on an array or array
element, name2 provides which index into the array was affected. This
information is present even when name1 refers to a scalar, which may
happen if the upvar command was used to create a reference to a single
array element. If an entire array is being deleted and the trace was
registered on the overall array, rather than a single element, then
name1 gives the array name and name2 is an empty string. Op indicates
what operation is being performed on the variable, and is one of read,
write, or unset as defined above.
CommandPrefix executes in the same context as the code that invoked the
traced operation: if the variable was accessed as part of a Tcl procedure,
then commandPrefix will have access to the same local variables as code in
the procedure. This context may be different than the context in which the
trace was created. If commandPrefix invokes a procedure (which it normally
does) then the procedure will have to use upvar or uplevel if it wishes to
access the traced variable. Note also that name1 may not necessarily be
the same as the name used to set the trace on the variable; differences
can occur if the access is made through a variable defined with the upvar
command.
For read and write traces, commandPrefix can modify the variable to affect
the result of the traced operation. If commandPrefix modifies the value of
a variable during a read or write trace, then the new value will be
returned as the result of the traced operation. The return value from
commandPrefix is ignored except that if it returns an error of any sort
then the traced operation also returns an error with the same error message
returned by the trace command (this mechanism can be used to implement
read-only variables, for example). For write traces, commandPrefix is
invoked after the variable's value has been changed; it can write a new
value into the variable to override the original value specified in the
write operation. To implement read-only variables, commandPrefix will have
to restore the old value of the variable.
While commandPrefix is executing during a read or write trace, traces on
the variable are temporarily disabled. This means that reads and writes
invoked by commandPrefix will occur directly, without invoking
commandPrefix (or any other traces) again. However, if commandPrefix
unsets the variable then unset traces will be invoked.
When an unset trace is invoked, the variable has already been deleted: it
will appear to be undefined with no traces. If an unset occurs because of
a procedure return, then the trace will be invoked in the variable context
of the procedure being returned to: the stack frame of the returning
procedure will no longer exist. Traces are not disabled during unset
traces, so if an unset trace command creates a new trace and accesses the
variable, the trace will be invoked. Any errors in unset traces are ignored.
If there are multiple traces on a variable they are invoked in order of
creation, most-recent first. If one trace returns an error, then no further
traces are invoked for the variable. If an array element has a trace set,
and there is also a trace set on the array as a whole, the trace on the
overall array is invoked before the one on the element.
Once created, the trace remains in effect either until the trace is removed
with the trace remove variable command described below, until the variable
is unset, or until the interpreter is deleted. Unsetting an element of array
will remove any traces on that element, but will not remove traces on the
overall array.
This command returns an empty string."
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace add execution"
@cmd -name "Built-in: trace add execution" -help\
@cmd -name "Built-in: trace add execution"\
-summary\
"Add execution trace for operation(s): enter leave enterstep leavestep."\
-help\
"Arrange for commandPrefix to be executed (with additional arguments)
whenever command name is executed, with traces occurring at the points
indicated by the list ops. Name will be resolved using the usual namespace
@ -5159,6 +5283,25 @@ tcl::namespace::eval punk::args::tclcore {
"
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace remove"
@cmd -name "Built-in: trace remove"\
-summary\
"Remove a command, execution or variable trace."\
-help\
"Remove a command, execution or variable trace."
@form -synopsis "trace remove type name ops ?args?"
@leaders
type -choicegroups {
"" {command execution variable}
}\
-choiceinfo {
command {{doctype punkargs} {subhelp ::trace remove command}}
execution {{doctype punkargs} {subhelp ::trace remove execution}}
variable {{doctype punkargs} {subhelp ::trace remove variable}}
}
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace remove command"
@cmd -name "Built-in: trace remove command" -help\
@ -5175,6 +5318,44 @@ tcl::namespace::eval punk::args::tclcore {
delete"
commandPrefix
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace remove execution"
@cmd -name "Built-in: trace remove execution" -help\
"If there is a trace set on command name with the operations and command
given by opList and commandPrefix, then the trace is removed, so that
commandPrefix will never again be invoked. Returns an empty string. If
name does not exist, the command will throw an error"
@values
name -type string -help\
"Name of command"
opList -type list -help\
"A list of one or more of the following items:
enter
leave
enterstep
leavestep"
commandPrefix
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace remove variable"
@cmd -name "Built-in: trace remove variable" -help\
"If there is a trace set on command name with the operations and command
given by opList and commandPrefix, then the trace is removed, so that
commandPrefix will never again be invoked. Returns an empty string."
@values
name -type string -help\
"Name of command"
opList -type list -help\
"A list of one or more of the following items:
array
read
write
unset"
commandPrefix
} "@doc -name Manpage: -url [manpage_tcl trace]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---

123
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm

@ -66,12 +66,14 @@ namespace eval punk::cap::handlers::templates {
set multivendor_package_whitelist [list punk::mix::templates]
#for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the projectbase rather than rechecking it each time the templates handler api is called
#for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the base rather than rechecking it each time the templates handler api is called
#for template pathtype absolute - we can do the same.
#There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change.
#adhoc and currentproject* paths are relative to cwd - so no projectbase information can be stored at registration time.
#not all template item types will need projectbase information - as the item data may be self-contained within the template structure -
#adhoc and currentproject* pathtypes are relative to cwd - so no base information can be stored at registration time.
#module pathtype base is resolved by the providing package itself at load time using 'info script'
#not all template item types will need base information - as the item data may be self-contained within the template structure -
#but project_layout will need it - or at least need to know if there is no project - because project_layout data is never stored in the template folder structure directly.
switch -- $pathtype {
adhoc {
@ -86,44 +88,19 @@ namespace eval punk::cap::handlers::templates {
if {[file pathtype $path] ne "relative"} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
}
#todo - check for mounted modpod (or tarjar?)
#e.g //zipfs:/#modpod/d1/d2/#mounted-modpod-libname-V.v
#(or equivalent for vfs eg c:/repo/jn/shellspy/modules/test/#modpod/test/#mounted-modpod-libname-V.v
set provide_statement [package ifneeded $pkg [package require $pkg]]
set tmfile [lindex $provide_statement end]
if {[interp issafe]} {
#default safe interp can't use file exists/normalize etc.. but safe interp may have a policy/alias set allowing file access to certain paths - so test if file exists is usable
if {[catch {file exists $tmfile} tm_exists]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING (expected in most safe interps) - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
flush stderr
return 0
}
} else {
set tm_exists [file exists $tmfile]
}
if {!$tm_exists} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
flush stderr
#The package should have provided a base folder (by using 'info script') when it was loaded
#'package ifneeded' for a module gives initial path information for a package - but it might redirect to sourcing from a different location such as being mounted elsewhere in a vfs,
#in which case we wouldn't get the correct path.
if {![dict exists $capdict base]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing the 'base' key (required when pathtype is 'module')"
return 0
}
set tmfolder [file dirname $tmfile]
#todo - handle wrapped or unwrapped tarjar files - in which case we have to adjust tmfolder appropriately
#set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder
#set projectinfo [punk::repo::find_repos $tmfolder] ;#slow - REVIEW
#REVIEW - do we even want project base relative to where the lib came from??
#should be relative to executable? or cwd?
set projectbase [punk::repo::find_project $tmfolder]
#store the projectbase even if it's empty string
set extended_capdict $capdict
set resolved_path [file join $tmfolder $path]
set base [dict get $capdict base]
set resolved_path [file join $base $path]
dict set extended_capdict resolved_path $resolved_path
dict set extended_capdict projectbase $projectbase
dict set extended_capdict base $base
}
currentproject_multivendor {
#currently only intended for punk::mix::templates - review if 3rd party _multivendor trees even make sense
@ -156,14 +133,18 @@ namespace eval punk::cap::handlers::templates {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
return 0
}
set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
#set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
set shellbase [file dirname [file dirname [file normalize [info nameofexecutable]/___]]]
#set projectinfo [punk::repo::find_repos $shellbase]
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $shellbase]
#set base [dict get $projectinfo closest]
#may result in empty base for no project found
set base [punk::repo::find_project $shellbase]
set extended_capdict $capdict
dict set extended_capdict vendor $vendor
dict set extended_capdict projectbase $projectbase
dict set extended_capdict base $base
}
shellproject_multivendor {
#currently only intended for punk::templates - review if 3rd party _multivendor trees even make sense
@ -175,14 +156,15 @@ namespace eval punk::cap::handlers::templates {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
return 0
}
set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
#set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
set shellbase [file dirname [file dirname [file normalize [info nameofexecutable]/___]]]
#set projectinfo [punk::repo::find_repos $shellbase]
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $shellbase]
#set base [dict get $projectinfo closest]
set base [punk::repo::find_project $shellbase]
set extended_capdict $capdict
dict set extended_capdict vendor $vendor
dict set extended_capdict projectbase $projectbase
dict set extended_capdict base $base
}
absolute {
if {[file pathtype $path] ne "absolute"} {
@ -194,15 +176,12 @@ namespace eval punk::cap::handlers::templates {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' which doesn't seem to exist"
return 0
}
#set projectinfo [punk::repo::find_repos $normpath]
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $normpath]
#todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder
set extended_capdict $capdict
dict set extended_capdict resolved_path $normpath
dict set extended_capdict vendor $vendor
dict set extended_capdict projectbase $projectbase
dict set extended_capdict base ""
}
default {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' with unrecognised type $pathtype"
@ -332,16 +311,16 @@ namespace eval punk::cap::handlers::templates {
set path [dict get $capdecl_extended path]
set pathtype [dict get $capdecl_extended pathtype]
set vendor [dict get $capdecl_extended vendor]
# projectbase not present in capdecl_extended for all template pathtypes
# base not present in capdecl_extended for all template pathtypes ?
if {$pathtype eq "adhoc"} {
#e.g (cwd)/templates
set targetpath [file join $startdir [dict get $capdecl_extended path]]
if {[file isdirectory $targetpath]} {
dict lappend found_paths_adhoc $vendor [list pkg $pkg path $targetpath pathtype $pathtype]
dict lappend found_paths_adhoc $vendor [list pkg $pkg path $targetpath pathtype $pathtype base $startdir]
}
} elseif {$pathtype eq "module"} {
set module_projectroot [dict get $capdecl_extended projectbase]
dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot]
set mbase [dict get $capdecl_extended base]
dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype base $mbase]
} elseif {$pathtype eq "currentproject_multivendor"} {
#set searchbase $startdir
#set pathinfo [punk::repo::find_repos $searchbase]
@ -357,11 +336,11 @@ namespace eval punk::cap::handlers::templates {
set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *]
foreach vf $vendorfolders {
if {$vf ne "_project"} {
dict lappend found_paths_currentproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype]
dict lappend found_paths_currentproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype base $pwd_projectroot]
}
}
if {[file isdirectory [file join $vendorbase _project]]} {
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype]
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype base $pwd_projectroot]
}
}
set custombase [file join $deckbase custom]
@ -369,11 +348,11 @@ namespace eval punk::cap::handlers::templates {
set customfolders [glob -nocomplain -dir $custombase -type d -tails *]
foreach cf $customfolders {
if {$cf ne "_project"} {
dict lappend found_paths_currentproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype]
dict lappend found_paths_currentproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype base $pwd_projectroot]
}
}
if {[file isdirectory [file join $custombase _project]]} {
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype]
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype base $pwd_projectroot]
}
}
}
@ -385,7 +364,7 @@ namespace eval punk::cap::handlers::templates {
#path relative to projectroot already validated by handler as being within a currentproject_multivendor tree
set targetfolder [file join $pwd_projectroot $path]
if {[file isdirectory $targetfolder]} {
dict lappend found_paths_currentproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype]
dict lappend found_paths_currentproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype base $pwd_projectroot]
}
}
} elseif {$pathtype eq "shellproject_multivendor"} {
@ -394,7 +373,7 @@ namespace eval punk::cap::handlers::templates {
#set pathinfo [punk::repo::find_repos $shellbase]
#set pwd_projectroot [dict get $pathinfo closest]
set shell_projectroot [dict get $capdecl_extended projectbase]
set shell_projectroot [dict get $capdecl_extended base]
if {$shell_projectroot ne ""} {
set deckbase [file join $shell_projectroot $path]
if {![file exists $deckbase]} {
@ -406,11 +385,11 @@ namespace eval punk::cap::handlers::templates {
set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *]
foreach vf $vendorfolders {
if {$vf ne "_project"} {
dict lappend found_paths_shellproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype base $shell_projectroot]
}
}
if {[file isdirectory [file join $vendorbase _project]]} {
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype base $shell_projectroot]
}
}
set custombase [file join $deckbase custom]
@ -418,11 +397,11 @@ namespace eval punk::cap::handlers::templates {
set customfolders [glob -nocomplain -dir $custombase -type d -tails *]
foreach cf $customfolders {
if {$cf ne "_project"} {
dict lappend found_paths_shellproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype base $shell_projectroot]
}
}
if {[file isdirectory [file join $custombase _project]]} {
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype base $shell_projectroot]
}
}
@ -434,17 +413,17 @@ namespace eval punk::cap::handlers::templates {
#set pathinfo [punk::repo::find_repos $shellbase]
#set pwd_projectroot [dict get $pathinfo closest]
set shell_projectroot [dict get $capdecl_extended projectbase]
set shell_projectroot [dict get $capdecl_extended base]
if {$shell_projectroot ne ""} {
set targetfolder [file join $shell_projectroot $path]
if {[file isdirectory $targetfolder]} {
dict lappend found_paths_shellproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype base $shell_projectroot]
}
}
} elseif {$pathtype eq "absolute"} {
#lappend found_paths [dict get $capdecl_extended resolved_path]
set abs_projectroot [dict get $capdecl_extended projectbase]
dict lappend found_paths_absolute $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $abs_projectroot]
set abs_projectroot [dict get $capdecl_extended base]
dict lappend found_paths_absolute $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype base $abs_projectroot]
}
}
@ -460,19 +439,19 @@ namespace eval punk::cap::handlers::templates {
dict for {vendor pathinfolist} $found_paths_module {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor]
}
}
#Templates within project of shell we launched with has lower priority than 'currentproject' (which depends on our CWD)
dict for {vendor pathinfolist} $found_paths_shellproject_multivendor {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor]
}
}
dict for {vendor pathinfolist} $found_paths_shellproject {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor]
}
}
@ -488,7 +467,7 @@ namespace eval punk::cap::handlers::templates {
}
dict for {vendor pathinfolist} $found_paths_absolute {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor]
}
}
#adhoc paths relative to cwd (or specified -startdir) can override any
@ -540,9 +519,9 @@ namespace eval punk::cap::handlers::templates {
set tailats [join [lrange $atparts 1 end] @]
# @ parts after the first are part of the path within the project_layouts structure
set subpathlist [split $tailats +]
if {[dict exists $refinfo sourceinfo projectbase]} {
if {[dict exists $refinfo sourceinfo base]} {
#some template pathtypes refer to the projectroot from the template - not the cwd
set ref_projectroot [dict get $refinfo sourceinfo projectbase]
set ref_projectroot [dict get $refinfo sourceinfo base]
} else {
set ref_projectroot $projectroot
}

143
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm

@ -497,78 +497,6 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}]
}
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed)
proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
set ns_mapped [string map {:: \uFFFF} $ns]
#puts stderr "aliases ns: $ns_mapped"
set segments [split $ns_mapped \uFFFF] ;#include empty string before leading ::
if {![string length [lindex $segments end]]} {
#special case for :: only include leading segment rather thatn {} {}
set segments [lrange $segments 0 end-1]
}
set segcount [llength $segments] ;#only match number of segments matching current ns
set all_aliases [interp aliases {}]
set matched [list]
foreach a $all_aliases {
#normalize with leading ::
if {![string match ::* $a]} {
set abs ::$a
} else {
set abs $a
}
set asegs [split [string map {:: \uFFFF} $abs] \uFFFF]
set acount [llength $asegs]
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments"
if {($acount - 1) == $segcount} {
if {[lrange $asegs 0 end-1] eq $segments} {
if {[string match $glob [lindex $asegs end]]} {
#report this alias in the current namespace - even though there may be no matching command
lappend matched $a ;#add raw alias token which may or may not have leading ::
}
}
}
}
#set matched_abs [lsearch -all -inline $all_aliases $glob]
return $matched
}
proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
if {[llength $args]} {
if {$aliasorglob in [interp aliases ""]} {
set existing [interp alias "" $aliasorglob]
puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)"
}
if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} {
#use empty string/whitespace as intention to delete alias
return [interp alias "" $aliasorglob ""]
}
return [interp alias "" $aliasorglob "" {*}$args]
} else {
if {![string length $aliasorglob]} {
set aliaslist [punk::lib::aliases]
puts -nonewline stderr $aliaslist
return
}
#we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias
set target [interp alias "" $aliasorglob]
if {[llength $target]} {
return $target
}
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} {
set aliaslist [punk::lib::aliases $aliasorglob]
puts -nonewline stderr $aliaslist
return
}
return [list]
}
}
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
@ -2242,7 +2170,51 @@ namespace eval punk::lib {
}
}
punk::args::define {
@id -id ::punk::lib::is_indexset
@cmd -name punk::lib::is_indexset\
-summary\
"Validate string is a comma-delimited 'indexset'."\
-help\
"Validate that a string is an 'indexset'
An indexset consists of a comma delimited list of indexes or index-ranges.
The indexes are 0-based.
Ranges must be specified with .. as the separator.
Common whitespace elements space,tab,newlines are ignored.
Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands,
e.g end-2 or 2+2.
see indexset_resolve"
@values -min 2 -max 2
indexset -type string
}
proc is_indexset {indexset} {
#collapse internal whitespace (for basic whitespace set we allow)
set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset]
if {![regexp {^[\-\+_end,\.0-9]*$} $indexset]} {
return 0
}
set ranges [split $indexset ,]
foreach r $ranges {
set validateindices [list]
set rposn [string first .. $r]
if {$rposn >= 0} {
lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end]
} else {
#'range' is just an index
set validateindices [list $r]
}
foreach v $validateindices {
if {$v eq "" || $v eq "end"} {continue}
if {[string is integer -strict $v]} {continue}
if {[catch {lindex {} $v}]} {
return 0
}
}
}
return 1
}
#review - compare to IMAP4 methods of specifying ranges?
punk::args::define {
@id -id ::punk::lib::indexset_resolve
@ -2251,6 +2223,8 @@ namespace eval punk::lib {
"Resolve an indexset to a list of integers based on supplied list or string length."\
-help\
"Resolve an 'indexset' to a list of actual indices within the range of the provided numitems value.
e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9
An indexset consists of a comma delimited list of indexes or index-ranges.
The indexes are 0-based.
Ranges must be specified with .. as the separator.
@ -2258,27 +2232,30 @@ namespace eval punk::lib {
Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands,
e.g end-2 or 2+2.
end means the last page.
end-1 means the second last page.
end means the last item.
end-1 means the second last item.
0.. is the same as 0..end.
examples:
indexset examples:
1,3..
output the page index 1 (2nd page) followed by all from index 3 to the end.
output the index 1 (2nd item) followed by all from index 3 to the end.
'indexset_resolve 4 1,3..' -> 1 3
'indexset_resolve 10 1,3..' -> 1 3 4 5 6 7 8 9
0-2,end
output the first 3 pages, and the last page.
output the first 3 indices, and the last index.
end-1..0
output the indexes in reverse order from 2nd last page to first page."
output the indexes in reverse order from 2nd last item to first item."
@values -min 2 -max 2
numitems -type integer
indexset -type string
indexset -type indexset -help "comma delimited specification for indices to return"
}
proc indexset_resolve {numitems indexset} {
if {![string is integer -strict $numitems] || ![regexp {^[\-\+_end,\.0-9]*$} $indexset]} {
if {![string is integer -strict $numitems] || ![is_indexset $indexset]} {
#use parser on unhappy path only
set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve]
uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg]
}
set index_list [list] ;#list of actual indexes within the range
}
set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace
set index_list [list] ;#list of actual indexes within the range
set iparts [split $indexset ,]
set index_list [list]
foreach ipart $iparts {
@ -2286,7 +2263,7 @@ namespace eval punk::lib {
set rposn [string first .. $ipart]
if {$rposn>=0} {
#range
lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb
lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb
set rawa [string trim $rawa]
set rawb [string trim $rawb]
if {$rawa eq ""} {set rawa 0}

4
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm

@ -1,5 +1,5 @@
# -*- tcl -*-
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
@ -17,7 +17,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::libunknown 0 0.1]
#[manpage_begin punkshell_module_punk::libunknown 0 0.1]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]

5
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix-0.2.tm

@ -7,6 +7,11 @@ tcl::namespace::eval punk::mix {
package require punk::cap::handlers::templates ;#handler for templates cap
punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us
#todo: use tcllib pluginmgr to load all modules that provide 'punk.templates'
#review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages
#We may also need to better control the order of module and library paths in the safe interps pluginmgr uses.
#todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation)
package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap
set t [time {
if {[catch {punk::mix::templates::provider register *} errM]} {

14
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm

@ -480,7 +480,7 @@ namespace eval punk::mix::cli {
}
#repotypes *could* be both git and fossil - so report both if so
if {"git" in $repotypes} {
append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n
append result "\nGIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n
if {[string length [set git_prog [auto_execok git]]]} {
set git_remotes [exec {*}$git_prog remote -v]
append result $git_remotes
@ -791,10 +791,10 @@ namespace eval punk::mix::cli {
if {[catch {
file copy -force $modulefile $target_module_dir
} errMsg]} {
puts stderr "FAILED to copy zip modpod module $modulefile to $target_module_dir"
puts stderr "[punk::ansi::a+ red]FAILED to copy zip modpod module $modulefile to $target_module_dir[punk::ansi::a]"
$event targetset_end FAILED -note "could not copy $modulefile"
} else {
puts stderr "Copied zip modpod module $modulefile to $target_module_dir"
puts stderr "[punk::ansi::a+ green]Copied zip modpod module $modulefile to $target_module_dir[punk::ansi::a]"
# -- --- --- --- --- ---
$event targetset_end OK -note "zip modpod"
}
@ -821,7 +821,7 @@ namespace eval punk::mix::cli {
if {$tmfile_versionsegment eq $magicversion} {
set versionfiledata ""
if {![file exists $versionfile]} {
puts stderr "\nWARNING: Missing buildversion text file: $versionfile"
puts stderr "\n[punk::ansi::a+ brightyellow]WARNING: Missing buildversion text file: $versionfile[punk::ansi::a]"
puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n"
set module_build_version "0.1"
} else {
@ -830,7 +830,7 @@ namespace eval punk::mix::cli {
set ln0 [lindex [split $versionfiledata \n] 0]
set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r]
if {![util::is_valid_tm_version $ln0]} {
puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file"
puts stderr "ERROR:[punk::ansi::a+ red] build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file[punk::ansi::a]"
exit 3
}
set module_build_version $ln0
@ -973,10 +973,10 @@ namespace eval punk::mix::cli {
if {[catch {
file copy -force $modulefile $target_module_dir
} errMsg]} {
puts stderr "FAILED to copy tarjar module $modulefile to $target_module_dir"
puts stderr "[punk::ansi::a+ red]FAILED to copy tarjar module $modulefile to $target_module_dir[punk::ansi::a]"
$event targetset_end FAILED -note "could not copy $modulefile"
} else {
puts stderr "Copied tarjar module $modulefile to $target_module_dir"
puts stderr "[punk::ansi::a+ green]Copied tarjar module $modulefile to $target_module_dir[punk::ansi::a]"
# -- --- --- --- --- ---
$event targetset_end OK -note "tarjar"
}

BIN
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.2.tm

Binary file not shown.

3414
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm

File diff suppressed because it is too large Load Diff

2
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm

@ -328,7 +328,7 @@ tcl::namespace::eval punk::packagepreference {
catch {
#$COMMANDSTACKNEXT require $pkg {*}$vwant
#j2
$COMMANDSTACKNEXT require punk::args::$dp
$COMMANDSTACKNEXT require punk::args::moduledoc::$dp
}
}
#---------------------------------------------------------------

54
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/pipe-1.0.tm

@ -1,6 +1,6 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::pipe 0 1.0]
#[manpage_begin punkshell_module_punk::pipe 0 1.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
@ -61,48 +61,16 @@ package require Tcl 8.6-
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::pipe::class {
#*** !doctools
#[subsection {Namespace punk::pipe::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 ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::pipe {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection {Namespace punk::pipe}]
#[para] Core API functions for punk::pipe
#[para] Core API functions for punk::pipe
#[list_begin definitions]
@ -110,13 +78,13 @@ tcl::namespace::eval punk::pipe {
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1
# #[para]Description of sample1
# #[para] Arguments:
# # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n.
# # [list_end]
# return "ok"
# return "ok"
#}
#https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/
@ -735,16 +703,6 @@ tcl::namespace::eval punk::pipe::lib {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::pipe::system {
#*** !doctools
#[subsection {Namespace punk::pipe::system}]
#[para] Internal functions that are not part of the API
#}
# == === === === === === === === === === === === === === ===

25
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm

@ -3063,6 +3063,11 @@ namespace eval repl {
return $stack
}
}
#autodoc for ensemble, or a punk::args::define doc here
#will not alow discovery of the documentation from within an interp that has
#only alias access to this - as the docs (indeed even the namespace) won't
#exist in the calling interp.
namespace eval ::repl::interphelpers::subshell_ensemble {
namespace export {[a-z]*}
namespace ensemble create
@ -3259,7 +3264,7 @@ namespace eval repl {
debug\
punk::ns\
textblock\
punk::args::tclcore\
punk::args::moduledoc::tclcore\
punk::aliascore\
]
@ -3333,8 +3338,8 @@ namespace eval repl {
#review
code alias ::shellfilter::stack ::shellfilter::stack
#code alias ::punk::lib::set_clone ::punk::lib::set_clone
#code alias ::aliases ::punk::lib::aliases
code alias ::punk::lib::aliases ::punk::lib::aliases
#code alias ::aliases ::punk::ns::aliases
code alias ::punk::ns::aliases ::punk::ns::aliases
namespace eval ::codeinterp {}
code alias ::md5::md5 ::repl::interphelpers::md5
@ -3443,7 +3448,7 @@ namespace eval repl {
interp eval code {
package require punk::lib
package require punk::args
catch {package require punk::args::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical
catch {package require punk::args::moduledoc::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical
package require textblock
}
@ -3614,7 +3619,7 @@ namespace eval repl {
}} [punk::config::configure running]
package require textblock
catch {package require punk::args::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical
catch {package require punk::args::moduledoc::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical
} errM]} {
puts stderr "========================"
puts stderr "code interp error:"
@ -3632,6 +3637,16 @@ namespace eval repl {
}
}
code alias repl ::repl::interphelpers::repl_ensemble
code eval {
punk::args::define {
@id -id ::subshell
@cmd -name ::subshell\
-summary "Launch in-process subshell"\
-help "Launch a thread-based subshell"
shellname -type string -optional 0 -choices {punk punksafe safe safebase}
}
}
code alias subshell ::repl::interphelpers::subshell_ensemble
code alias quit ::repl::interphelpers::quit
code alias editbuf ::repl::interphelpers::editbuf

1
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm

@ -58,7 +58,6 @@ package require punk::args
package require punk::char
package require punk::ansi
package require punk::lib
catch {package require patternpunk}
package require overtype
package require struct::set

12
src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl

@ -1760,9 +1760,10 @@ if {$::punkboot::command eq "vendorupdate"} {
set vendor_config $sourcefolder/vendormodules$which/include_modules.config ;#todo - change to toml
if {[file exists $vendor_config]} {
set targetroot $sourcefolder/vendormodules$which
set local_modules [list]
source $vendor_config ;#populate $local_modules $git_modules $fossil_modules with project-specific list
if {![llength $local_modules]} {
puts stderr "src/vendormodules$which No local vendor modules configured for updating (config file: $vendor_config)"
puts stderr "\nsrc/vendormodules$which No local vendor modules configured for updating (config file: $vendor_config)"
} else {
if {[catch {
#----------
@ -1775,10 +1776,15 @@ if {$::punkboot::command eq "vendorupdate"} {
set installation_event ""
}
#todo - sync alg with bootsupport_localupdate!
foreach {relpath requested_module} $local_modules {
foreach {localpath requested_module} $local_modules {
set requested_module [string trim $requested_module :]
set module_subpath [string map {:: /} [namespace qualifiers $requested_module]]
set srclocation [file join $projectroot $relpath $module_subpath]
if {[file pathtype $localpath] eq "relative"} {
#This would actually work for absolute paths too as file join c:/test c:/etc ignores first arg and returns c:/etc
set srclocation [file join $projectroot $localpath $module_subpath]
} else {
set srclocation [file join $localpath $module_subpath]
}
#puts stdout "$relpath $module $module_subpath $srclocation"
#todo - check if requested_module has version extension and allow explicit versions instead of just latest

3
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config

@ -23,6 +23,7 @@ set bootsupport_modules [list\
src/vendormodules patterncmd\
src/vendormodules patternlib\
src/vendormodules patternpredator2\
src/vendormodules patterncipher\
src/vendormodules promise\
src/vendormodules sha1\
src/vendormodules tomlish\
@ -50,7 +51,7 @@ set bootsupport_modules [list\
modules punk::ansi\
modules punk::assertion\
modules punk::args\
modules punk::args::tclcore\
modules punk::args::moduledoc::tclcore\
modules punk::cap\
modules punk::cap::handlers::caphandler\
modules punk::cap::handlers::scriptlibs\

5989
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/metaface-1.2.8.tm

File diff suppressed because it is too large Load Diff

1459
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncipher-0.1.1.tm

File diff suppressed because it is too large Load Diff

639
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncmd-1.2.8.tm

@ -0,0 +1,639 @@
package provide patterncmd [namespace eval patterncmd {
variable version
set version 1.2.8
}]
namespace eval pattern {
variable idCounter 1 ;#used by pattern::uniqueKey
namespace eval cmd {
namespace eval util {
package require overtype
variable colwidths_lib [dict create]
variable colwidths_lib_default 15
dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""]
dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""]
dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""]
dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"]
proc colhead {type args} {
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
set line ""
foreach colname [dict keys $colwidths] {
append line "[col $type $colname [string totitle $colname] {*}$args]"
}
return $line
}
proc colbreak {type} {
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
set line ""
foreach colname [dict keys $colwidths] {
append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]"
}
return $line
}
proc col {type col val args} {
# args -head bool -tail bool ?
#----------------------------------------------------------------------------
set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify]
dict set default -backchar ""
dict set default -headchar ""
dict set default -tailchar ""
dict set default -headoverridechar ""
dict set default -tailoverridechar ""
dict set default -justify "left"
if {([llength $args] % 2) != 0} {
error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' "
}
foreach {k v} $args {
if {$k ni $known_opts} {
error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'"
}
}
set opts [dict merge $default $args]
set backchar [dict get $opts -backchar]
set headchar [dict get $opts -headchar]
set tailchar [dict get $opts -tailchar]
set headoverridechar [dict get $opts -headoverridechar]
set tailoverridechar [dict get $opts -tailoverridechar]
set justify [dict get $opts -justify]
#----------------------------------------------------------------------------
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
#calculate headwidths
set headwidth 0
set tailwidth 0
foreach {key def} $colwidths {
set thisheadlen [string length [dict get $def head]]
if {$thisheadlen > $headwidth} {
set headwidth $thisheadlen
}
set thistaillen [string length [dict get $def tail]]
if {$thistaillen > $tailwidth} {
set tailwidth $thistaillen
}
}
set spec [dict get $colwidths $col]
if {[string length $backchar]} {
set ch $backchar
} else {
set ch [dict get $spec ch]
}
set num [dict get $spec num]
set headchar [dict get $spec head]
set tailchar [dict get $spec tail]
if {[string length $headchar]} {
set headchar $headchar
}
if {[string length $tailchar]} {
set tailchar $tailchar
}
#overrides only apply if the head/tail has a length
if {[string length $headchar]} {
if {[string length $headoverridechar]} {
set headchar $headoverridechar
}
}
if {[string length $tailchar]} {
if {[string length $tailoverridechar]} {
set tailchar $tailoverridechar
}
}
set head [string repeat $headchar $headwidth]
set tail [string repeat $tailchar $tailwidth]
set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]]
if {$justify eq "left"} {
set left_done [overtype::left $base "$head$val"]
return [overtype::right $left_done "$tail"]
} elseif {$justify in {centre center}} {
set mid_done [overtype::centre $base $val]
set left_mid_done [overtype::left $mid_done $head]
return [overtype::right $left_mid_done $tail]
} else {
set right_done [overtype::right $base "$val$tail"]
return [overtype::left $right_done $head]
}
}
}
}
}
#package require pattern
proc ::pattern::libs {} {
set libs [list \
pattern {-type core -note "alternative:pattern2"}\
pattern2 {-type core -note "alternative:pattern"}\
patterncmd {-type core}\
metaface {-type core}\
patternpredator2 {-type core}\
patterndispatcher {-type core}\
patternlib {-type core}\
patterncipher {-type optional -note optional}\
]
package require overtype
set result ""
append result "[cmd::util::colbreak lib]\n"
append result "[cmd::util::colhead lib -justify centre]\n"
append result "[cmd::util::colbreak lib]\n"
foreach libname [dict keys $libs] {
set libinfo [dict get $libs $libname]
append result [cmd::util::col lib library $libname]
if {[catch [list package present $libname] ver]} {
append result [cmd::util::col lib version "N/A"]
} else {
append result [cmd::util::col lib version $ver]
}
append result [cmd::util::col lib type [dict get $libinfo -type]]
if {[dict exists $libinfo -note]} {
set note [dict get $libinfo -note]
} else {
set note ""
}
append result [cmd::util::col lib note $note]
append result "\n"
}
append result "[cmd::util::colbreak lib]\n"
return $result
}
proc ::pattern::record {recname fields} {
if {[uplevel 1 [list namespace which $recname]] ne ""} {
error "(pattern::record) Can't create command '$recname': A command of that name already exists"
}
set index -1
set accessor [list ::apply {
{index rec args}
{
if {[llength $args] == 0} {
return [lindex $rec $index]
}
if {[llength $args] == 1} {
return [lreplace $rec $index $index [lindex $args 0]]
}
error "Invalid number of arguments."
}
}]
set map {}
foreach field $fields {
dict set map $field [linsert $accessor end [incr index]]
}
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec]
}
proc ::pattern::record2 {recname fields} {
if {[uplevel 1 [list namespace which $recname]] ne ""} {
error "(pattern::record) Can't create command '$recname': A command of that name already exists"
}
set index -1
set accessor [list ::apply]
set template {
{rec args}
{
if {[llength $args] == 0} {
return [lindex $rec %idx%]
}
if {[llength $args] == 1} {
return [lreplace $rec %idx% %idx% [lindex $args 0]]
}
error "Invalid number of arguments."
}
}
set map {}
foreach field $fields {
set body [string map [list %idx% [incr index]] $template]
dict set map $field [list ::apply $body]
}
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec]
}
proc ::argstest {args} {
package require cmdline
}
proc ::pattern::objects {} {
set result [::list]
foreach ns [namespace children ::pp] {
#lappend result [::list [namespace tail $ns] [set ${ns}::(self)]]
set ch [namespace tail $ns]
if {[string range $ch 0 2] eq "Obj"} {
set OID [string range $ch 3 end] ;#OID need not be digits (!?)
lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]]
}
}
return $result
}
proc ::pattern::name {num} {
#!todo - fix
#set ::p::${num}::(self)
lassign [interp alias {} ::p::$num] _predator info
if {![string length $_predator$info]} {
error "No object found for num:$num (no interp alias for ::p::$num)"
}
set invocants [dict get $info i]
set invocants_with_role_this [dict get $invocants this]
set invocant_this [lindex $invocants_with_role_this 0]
#lassign $invocant_this id info
#set map [dict get $info map]
#set fields [lindex $map 0]
lassign $invocant_this _id _ns _defaultmethod name _etc
return $name
}
proc ::pattern::with {cmd script} {
foreach c [info commands ::p::-1::*] {
interp alias {} [namespace tail $c] {} $c $cmd
}
interp alias {} . {} $cmd .
interp alias {} .. {} $cmd ..
return [uplevel 1 $script]
}
#system diagnostics etc
proc ::pattern::varspace_list {IID} {
namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables
set varspaces [list]
dict for {vname vdef} $o_variables {
set vs [dict get $vdef varspace]
if {$vs ni $varspaces} {
lappend varspaces $vs
}
}
if {$o_varspace ni $varspaces} {
lappend varspaces $o_varspace
}
return $varspaces
}
proc ::pattern::check_interfaces {} {
foreach ns [namespace children ::p] {
set IID [namespace tail $ns]
if {[string is digit $IID]} {
foreach ref [array names ${ns}::_iface::o_usedby] {
set OID [string range $ref 1 end]
if {![namespace exists ::p::${OID}::_iface]} {
puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n"
} else {
puts -nonewline stdout .
}
#if {![info exists ::p::${OID}::(self)]} {
# puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID"
#}
}
}
}
puts -nonewline stdout "\r\n"
}
#from: http://wiki.tcl.tk/8766 (Introspection on aliases)
#usedby: metaface-1.1.6+
#required because aliases can be renamed.
#A renamed alias will still return it's target with 'interp alias {} oldname'
# - so given newname - we require which_alias to return the same info.
proc ::pattern::which_alias {cmd} {
uplevel 1 [list ::trace add execution $cmd enterstep ::error]
catch {uplevel 1 $cmd} res
uplevel 1 [list ::trace remove execution $cmd enterstep ::error]
#puts stdout "which_alias $cmd returning '$res'"
return $res
}
# [info args] like proc following an alias recursivly until it reaches
# the proc it originates from or cannot determine it.
# accounts for default parameters set by interp alias
#
proc ::pattern::aliasargs {cmd} {
set orig $cmd
set defaultargs [list]
# loop until error or return occurs
while {1} {
# is it a proc already?
if {[string equal [info procs $cmd] $cmd]} {
set result [info args $cmd]
# strip off the interp set default args
return [lrange $result [llength $defaultargs] end]
}
# is it a built in or extension command we can get no args for?
if {![string equal [info commands $cmd] $cmd]} {
error "\"$orig\" isn't a procedure"
}
# catch bogus cmd names
if {[lsearch [interp aliases {}] $cmd]==-1} {
if {[catch {::pattern::which_alias $cmd} alias]} {
error "\"$orig\" isn't a procedure or alias or command"
}
#set cmd [lindex $alias 0]
if {[llength $alias]>1} {
set cmd [lindex $alias 0]
set defaultargs [concat [lrange $alias 1 end] $defaultargs]
} else {
set cmd $alias
}
} else {
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} {
# check if it is aliased in from another interpreter
if {[catch {interp target {} $cmd} msg]} {
error "Cannot resolve \"$orig\", alias leads to another interpreter."
}
if {$msg != {} } {
error "Not recursing into slave interpreter \"$msg\".\
\"$orig\" could not be resolved."
}
# check if defaults are set for the alias
if {[llength $cmdargs]>1} {
set cmd [lindex $cmdargs 0]
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs]
} else {
set cmd $cmdargs
}
}
}
}
}
proc ::pattern::aliasbody {cmd} {
set orig $cmd
set defaultargs [list]
# loop until error or return occurs
while {1} {
# is it a proc already?
if {[string equal [info procs $cmd] $cmd]} {
set result [info body $cmd]
# strip off the interp set default args
return $result
#return [lrange $result [llength $defaultargs] end]
}
# is it a built in or extension command we can get no args for?
if {![string equal [info commands $cmd] $cmd]} {
error "\"$orig\" isn't a procedure"
}
# catch bogus cmd names
if {[lsearch [interp aliases {}] $cmd]==-1} {
if {[catch {::pattern::which_alias $cmd} alias]} {
error "\"$orig\" isn't a procedure or alias or command"
}
#set cmd [lindex $alias 0]
if {[llength $alias]>1} {
set cmd [lindex $alias 0]
set defaultargs [concat [lrange $alias 1 end] $defaultargs]
} else {
set cmd $alias
}
} else {
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} {
# check if it is aliased in from another interpreter
if {[catch {interp target {} $cmd} msg]} {
error "Cannot resolve \"$orig\", alias leads to another interpreter."
}
if {$msg != {} } {
error "Not recursing into slave interpreter \"$msg\".\
\"$orig\" could not be resolved."
}
# check if defaults are set for the alias
if {[llength $cmdargs]>1} {
set cmd [lindex $cmdargs 0]
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs]
} else {
set cmd $cmdargs
}
}
}
}
}
proc ::pattern::uniqueKey2 {} {
#!todo - something else??
return [clock seconds]-[incr ::pattern::idCounter]
}
#used by patternlib package
proc ::pattern::uniqueKey {} {
return [incr ::pattern::idCounter]
#uuid with tcllibc is about 30us compared with 2us
# for large datasets, e.g about 100K inserts this would be pretty noticable!
#!todo - uuid pool with background thread to repopulate when idle?
#return [uuid::uuid generate]
}
#-------------------------------------------------------------------------------------------------------------------------
proc ::pattern::test1 {} {
set msg "OK"
puts stderr "next line should say:'--- saystuff:$msg"
::>pattern .. Create ::>thing
::>thing .. PatternMethod saystuff args {
puts stderr "--- saystuff: $args"
}
::>thing .. Create ::>jjj
::>jjj . saystuff $msg
::>jjj .. Destroy
::>thing .. Destroy
}
proc ::pattern::test2 {} {
set msg "OK"
puts stderr "next line should say:'--- property 'stuff' value:$msg"
::>pattern .. Create ::>thing
::>thing .. PatternProperty stuff $msg
::>thing .. Create ::>jjj
puts stderr "--- property 'stuff' value:[::>jjj . stuff]"
::>jjj .. Destroy
::>thing .. Destroy
}
proc ::pattern::test3 {} {
set msg "OK"
puts stderr "next line should say:'--- property 'stuff' value:$msg"
::>pattern .. Create ::>thing
::>thing .. Property stuff $msg
puts stderr "--- property 'stuff' value:[::>thing . stuff]"
::>thing .. Destroy
}
#---------------------------------
#unknown/obsolete
#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args}
if {0} {
proc ::p::internals::new_interface {{usedbylist {}}} {
set OID [incr ::p::ID]
::p::internals::new_object ::p::ifaces::>$OID "" $OID
puts "obsolete >> new_interface created object $OID"
foreach usedby $usedbylist {
set ::p::${OID}::_iface::o_usedby(i$usedby) 1
}
set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace)
#NOTE - o_varspace is only the default varspace for when new methods/properties are added.
# it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value.
set ::p::${OID}::_iface::o_constructor [list]
set ::p::${OID}::_iface::o_variables [list]
set ::p::${OID}::_iface::o_properties [dict create]
set ::p::${OID}::_iface::o_methods [dict create]
array set ::p::${OID}::_iface::o_definition [list]
set ::p::${OID}::_iface::o_open 1 ;#open for extending
return $OID
}
#temporary way to get OID - assumes single 'this' invocant
#!todo - make generic.
proc ::pattern::get_oid {_ID_} {
#puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]"
return [lindex [dict get $_ID_ i this] 0 0]
#set invocants [dict get $_ID_ i]
#set invocant_roles [dict keys $invocants]
#set role_members [dict get $invocants this]
##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list.
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;
#lassign $this_invocant OID this_info
#
#return $OID
}
#compile the uncompiled level1 interface
#assert: no more than one uncompiled interface present at level1
proc ::p::meta::PatternCompile {self} {
error "PatternCompile ????"
upvar #0 $self SELFMAP
set ID [lindex $SELFMAP 0 0]
set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces
set iid -1
foreach i $patterns {
if {[set ::p::${i}::_iface::o_open]} {
set iid $i ;#found it
break
}
}
if {$iid > -1} {
#!todo
::p::compile_interface $iid
set ::p::${iid}::_iface::o_open 0
} else {
#no uncompiled interface present at level 1. Do nothing.
return
}
}
proc ::p::meta::Def {self} {
error ::p::meta::Def
upvar #0 $self SELFMAP
set self_ID [lindex $SELFMAP 0 0]
set IFID [lindex $SELFMAP 1 0 end]
set maxc1 0
set maxc2 0
set arrName ::p::${IFID}::
upvar #0 $arrName state
array set methods {}
foreach nm [array names state] {
if {[regexp {^m-1,name,(.+)} $nm _match mname]} {
set methods($mname) [set state($nm)]
if {[string length $mname] > $maxc1} {
set maxc1 [string length $mname]
}
if {[string length [set state($nm)]] > $maxc2} {
set maxc2 [string length [set state($nm)]]
}
}
}
set bg1 [string repeat " " [expr {$maxc1 + 2}]]
set bg2 [string repeat " " [expr {$maxc2 + 2}]]
set r {}
foreach nm [lsort -dictionary [array names methods]] {
set arglist $state(m-1,args,$nm)
append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n"
}
return $r
}
}

2588
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patternlib-1.2.8.tm

File diff suppressed because it is too large Load Diff

755
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patternpredator2-1.2.8.tm

@ -0,0 +1,755 @@
proc ::p::internals::jaws {OID _ID_ args} {
#puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args"
#set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
yield
set w 1
set stack [list]
set wordcount [llength $args]
set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first
set unsupported 0
set operator ""
set operator_prev "" ;#used only by argprotect to revert to previous operator
if {$OID ne "null"} {
#!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!)
#upvar #0 ::p::${OID}::_meta::map MAP
set MAP [set ::p::${OID}::_meta::map]
} else {
# error "jaws - OID = 'null' ???"
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key
}
set invocantdata [dict get $MAP invocantdata]
lassign $invocantdata OID alias default_method object_command wrapped
set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code
#don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w
while {$w < $wordcount} {
set word [lindex $args [expr {$w -1}]]
#puts stdout "w:$w word:$word stack:$stack"
if {$operator eq "argprotect"} {
set operator $operator_prev
lappend stack $word
incr w
} else {
if {[llength $stack]} {
if {$word in $terminals} {
set reduction [list 0 $_ID_ {*}$stack ]
#puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w"
set _ID_ [yield $reduction]
set stack [list]
#set OID [::pattern::get_oid $_ID_]
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
if {$OID ne "null"} {
set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here!
} else {
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]]
#puts stderr "WARNING REVIEW: jaws-branch - leave empty??????"
}
#review - 2018. switched to _ID_ instead of MAP
lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command
#lassign [dict get $MAP invocantdata] OID alias default_method object_command
#puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command"
set operator $word
#don't incr w
#incr w
} else {
if {$operator eq "argprotect"} {
set operator $operator_prev
set operator_prev ""
lappend stack $word
} else {
#only look for leading argprotect chacter (-) if we're not already in argprotect mode
if {$word eq "--"} {
set operator_prev $operator
set operator "argprotect"
#Don't add the plain argprotector to the stack
} elseif {[string match "-*" $word]} {
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument)
set operator_prev $operator
set operator "argprotect"
lappend stack $word
} else {
lappend stack $word
}
}
incr w
}
} else {
#no stack
switch -- $word {.} {
if {$OID ne "null"} {
#we know next word is a property or method of a pattern object
incr w
set nextword [lindex $args [expr {$w - 1}]]
set command ::p::${OID}::$nextword
set stack [list $command] ;#2018 j
set operator .
if {$w eq $wordcount} {
set finished_args 1
}
} else {
# don't incr w
#set nextword [lindex $args [expr {$w - 1}]]
set command $object_command ;#taken from the MAP
set stack [list "_exec_" $command]
set operator .
}
} {..} {
incr w
set nextword [lindex $args [expr {$w -1}]]
set command ::p::-1::$nextword
#lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list.
set stack [list $command] ;#faster, and intent is clearer than lappend.
set operator ..
if {$w eq $wordcount} {
set finished_args 1
}
} {,} {
#puts stdout "Stackless comma!"
if {$OID ne "null"} {
set command ::p::${OID}::$default_method
} else {
set command [list $default_method $object_command]
#object_command in this instance presumably be a list and $default_method a list operation
#e.g "lindex {A B C}"
}
#lappend stack $command
set stack [list $command]
set operator ,
} {--} {
set operator_prev $operator
set operator argprotect
#no stack -
} {!} {
set command $object_command
set stack [list "_exec_" $object_command]
#puts stdout "!!!! !!!! $stack"
set operator !
} default {
if {$operator eq ""} {
if {$OID ne "null"} {
set command ::p::${OID}::$default_method
} else {
set command [list $default_method $object_command]
}
set stack [list $command]
set operator ,
lappend stack $word
} else {
#no stack - so we don't expect to be in argprotect mode already.
if {[string match "-*" $word]} {
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument)
set operator_prev $operator
set operator "argprotect"
lappend stack $word
} else {
lappend stack $word
}
}
}
incr w
}
}
} ;#end while
#process final word outside of loop
#assert $w == $wordcount
#trailing operators or last argument
if {!$finished_args} {
set word [lindex $args [expr {$w -1}]]
if {$operator eq "argprotect"} {
set operator $operator_prev
set operator_prev ""
lappend stack $word
incr w
} else {
switch -- $word {.} {
if {![llength $stack]} {
#set stack [list "_result_" [::p::internals::ref_to_object $_ID_]]
yieldto return [::p::internals::ref_to_object $_ID_]
error "assert: never gets here"
} else {
#puts stdout "==== $stack"
#assert - whenever _ID_ changed in this proc - we have updated the $OID variable
yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack]
error "assert: never gets here"
}
set operator .
} {..} {
#trailing .. after chained call e.g >x . item 0 ..
#puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$"
#set reduction [list 0 $_ID_ {*}$stack]
yieldto return [yield [list 0 $_ID_ {*}$stack]]
} {#} {
set unsupported 1
} {,} {
set unsupported 1
} {&} {
set unsupported 1
} {@} {
set unsupported 1
} {--} {
#set reduction [list 0 $_ID_ {*}$stack[set stack [list]]]
#puts stdout " -> -> -> about to call yield $reduction <- <- <-"
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ]
#set OID [::pattern::get_oid $_ID_]
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
if {$OID ne "null"} {
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here!
} else {
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ]
}
yieldto return $MAP
} {!} {
#error "untested branch"
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]]
#set OID [::pattern::get_oid $_ID_]
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
if {$OID ne "null"} {
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here!
} else {
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ]
}
lassign [dict get $MAP invocantdata] OID alias default_command object_command
set command $object_command
set stack [list "_exec_" $command]
set operator !
} default {
if {$operator eq ""} {
#error "untested branch"
lassign [dict get $MAP invocantdata] OID alias default_command object_command
#set command ::p::${OID}::item
set command ::p::${OID}::$default_command
lappend stack $command
set operator ,
}
#do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway.
lappend stack $word
}
if {$unsupported} {
set unsupported 0
error "trailing '$word' not supported"
}
#if {$operator eq ","} {
# incr wordcount 2
# set stack [linsert $stack end-1 . item]
#}
incr w
}
}
#final = 1
#puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]"
return [list 1 $_ID_ {*}$stack]
}
#trailing. directly after object
proc ::p::internals::ref_to_object {_ID_} {
set OID [lindex [dict get $_ID_ i this] 0 0]
upvar #0 ::p::${OID}::_meta::map MAP
lassign [dict get $MAP invocantdata] OID alias default_method object_command
set refname ::p::${OID}::_ref::__OBJECT
array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_]
if {[list {read} $traceCmd] ni [trace info variable $refname]} {
#puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'"
trace add variable $refname {read} $traceCmd
}
set traceCmd [list ::p::predator::object_array_trace $OID $_ID_]
if {[list {array} $traceCmd] ni [trace info variable $refname]} {
trace add variable $refname {array} $traceCmd
}
set traceCmd [list ::p::predator::object_write_trace $OID $_ID_]
if {[list {write} $traceCmd] ni [trace info variable $refname]} {
trace add variable $refname {write} $traceCmd
}
set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_]
if {[list {unset} $traceCmd] ni [trace info variable $refname]} {
trace add variable $refname {unset} $traceCmd
}
return $refname
}
proc ::p::internals::create_or_update_reference {OID _ID_ refname command} {
#if {[lindex $fullstack 0] eq "_exec_"} {
# #strip it. This instruction isn't relevant for a reference.
# set commandstack [lrange $fullstack 1 end]
#} else {
# set commandstack $fullstack
#}
#set argstack [lassign $commandstack command]
#set field [string map {> __OBJECT_} [namespace tail $command]]
set reftail [namespace tail $refname]
set argstack [lassign [split $reftail +] field]
set field [string map {> __OBJECT_} [namespace tail $command]]
#puts stderr "refname:'$refname' command: $command field:$field"
if {$OID ne "null"} {
upvar #0 ::p::${OID}::_meta::map MAP
} else {
#set map [dict get [lindex [dict get $_ID_ i this] 0 1] map]
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}]
}
lassign [dict get $MAP invocantdata] OID alias default_method object_command
if {$OID ne "null"} {
interp alias {} $refname {} $command $_ID_ {*}$argstack
} else {
interp alias {} $refname {} $command {*}$argstack
}
#set iflist [lindex $map 1 0]
set iflist [dict get $MAP interfaces level0]
#set iflist [dict get $MAP interfaces level0]
set field_is_property_like 0
foreach IFID [lreverse $iflist] {
#tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient.
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} {
set field_is_property_like 1
#There is a setter or getter (but not necessarily an entry in the o_properties dict)
break
}
}
#whether field is a property or a method - remove any commandrefMisuse_TraceHandler
foreach tinfo [trace info variable $refname] {
#puts "-->removing traces on $refname: $tinfo"
if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} {
trace remove variable $refname {*}$tinfo
}
}
if {$field_is_property_like} {
#property reference
set this_invocantdata [lindex [dict get $_ID_ i this] 0]
lassign $this_invocantdata OID _alias _defaultmethod object_command
#get fully qualified varspace
#
set propdict [$object_command .. GetPropertyInfo $field]
if {[dict exists $propdict $field]} {
set field_is_a_property 1
set propinfo [dict get $propdict $field]
set varspace [dict get $propinfo varspace]
if {$varspace eq ""} {
set full_varspace ::p::${OID}
} else {
if {[::string match "::*" $varspace]} {
set full_varspace $varspace
} else {
set full_varspace ::p::${OID}::$varspace
}
}
} else {
set field_is_a_property 0
#no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property
#this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later)
set full_varspace ::p::${OID}
}
#We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first))
set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field]
if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} {
trace add variable ${full_varspace}::o_${field} {write} $Hndlr
}
set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field]
if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} {
trace add variable ${full_varspace}::o_${field} {unset} $Hndlr
}
#supply all data in easy-access form so that propref_trace_read is not doing any extra work.
set get_cmd ::p::${OID}::(GET)$field
set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack]
if {[list {read} $traceCmd] ni [trace info variable $refname]} {
set fieldvarname ${full_varspace}::o_${field}
#synch the refvar with the real var if it exists
#catch {set $refname [$refname]}
if {[array exists $fieldvarname]} {
if {![llength $argstack]} {
#unindexed reference
array set $refname [array get $fieldvarname]
#upvar $fieldvarname $refname
} else {
set s0 [lindex $argstack 0]
#refs to nonexistant array members common? (catch vs 'info exists')
if {[info exists ${fieldvarname}($s0)]} {
set $refname [set ${fieldvarname}($s0)]
}
}
} else {
#refs to uninitialised props actually should be *very* common.
#If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive.
#Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch.
#set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches!
#puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------"
if {![llength $argstack]} {
#catch {set $refname [set ::p::${OID}::o_$field]}
if {[info exists $fieldvarname]} {
set $refname [set $fieldvarname]
#upvar $fieldvarname $refname
}
} else {
if {[llength $argstack] == 1} {
#catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]}
if {[info exists $fieldvarname]} {
set $refname [lindex [set $fieldvarname] [lindex $argstack 0]]
}
} else {
#catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]}
if {[info exists $fieldvarname]} {
set $refname [lindex [set $fieldvarname] $argstack]
}
}
}
#! what if someone has put a trace on ::errorInfo??
#set ::errorInfo $errorInfo_prev
}
trace add variable $refname {read} $traceCmd
set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname]
trace add variable $refname {write} $traceCmd
set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname]
trace add variable $refname {unset} $traceCmd
set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname]
# puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd"
trace add variable $refname {array} $traceCmd
}
} else {
#puts "$refname ====> adding refMisuse_traceHandler $alias $field"
#matching variable in order to detect attempted use as property and throw error
# 2018
#Note that we are adding a trace on a variable (the refname) which does not exist.
#this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex)
#we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added
##array set $refname {} ;#empty array
# - the empty array would mean a slightly better error message when misusing a command ref as an array
#but this seems like a code complication for little benefit
#review
trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field]
}
}
#trailing. after command/property
proc ::p::internals::ref_to_stack {OID _ID_ fullstack} {
if {[lindex $fullstack 0] eq "_exec_"} {
#strip it. This instruction isn't relevant for a reference.
set commandstack [lrange $fullstack 1 end]
} else {
set commandstack $fullstack
}
set argstack [lassign $commandstack command]
set field [string map {> __OBJECT_} [namespace tail $command]]
#!todo?
# - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace.
# - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted.
#references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself.
# - this would in theory allow a set of interface functions on the object which have direct access to the reference variables.
set refname ::p::${OID}::_ref::[join [concat $field $argstack] +]
if {[llength [info commands $refname]]} {
#todo - review - what if the field changed to/from a property/method?
#probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs
return $refname
}
::p::internals::create_or_update_reference $OID $_ID_ $refname $command
return $refname
}
namespace eval pp {
variable operators [list .. . -- - & @ # , !]
variable operators_notin_args ""
foreach op $operators {
append operators_notin_args "({$op} ni \$args) && "
}
set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands
#set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)}
}
interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks!
# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism.
#each map is a 2 element list of lists.
# form: {$commandinfo $interfaceinfo}
# commandinfo is of the form: {ID Namespace defaultmethod commandname _?}
#2018
#each map is a dict.
#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}}
#OID = Object ID (integer for now - could in future be a uuid)
proc ::p::predator2 {_ID_ args} {
#puts stderr "predator2: _ID_:'$_ID_' args:'$args'"
#set invocants [dict get $_ID_ i]
#set invocant_roles [dict keys $invocants]
#For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc.
#set this_role_members [dict get $invocants this]
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list.
#lassign $this_invocant this_OID this_info_dict
set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
set cheat 1 ;#
#-------
#Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call)
#(it should be functionally equivalent to remove this shortcut block)
if {$cheat} {
if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} {
set remaining_args [lassign $args dot method_or_prop]
#how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ???
set command ::p::${this_OID}::$method_or_prop
#REVIEW!
#e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say')
#if {[llength $command] > 1} {
# error "methods with spaces not included in test suites - todo fix!"
#}
#Dont use {*}$command - (so we can support methods with spaces)
#if {![llength [info commands $command]]} {}
if {[namespace which $command] eq ""} {
if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} {
#lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces
set command ::p::${this_OID}::(UNKNOWN)
#tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
} else {
return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found"
}
} else {
#tailcall {*}$command $_ID_ {*}$remaining_args
tailcall $command $_ID_ {*}$remaining_args
}
}
}
#------------
if {([llength $args] == 1) && ([lindex $args 0] eq "..")} {
return $_ID_
}
#puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args"
#puts stderr "this_info_dict: $this_info_dict"
if {![llength $args]} {
#should return some sort of public info.. i.e probably not the ID which is an implementation detail
#return cmd
return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID
#return a dict keyed on object command name - (suitable as use for a .. Create 'target')
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped
#return [list $object_command [list -id $this_OID ]]
} elseif {[llength $args] == 1} {
#short-circuit the single index case for speed.
if {[lindex $args 0] ni {.. . -- - & @ # , !}} {
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method
lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method
tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0]
} elseif {[lindex $args 0] eq {--}} {
#!todo - we could hide the invocant by only allowing this call from certain uplevel procs..
# - combined with using UUIDs for $OID, and a secured/removed metaface on the object
# - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases)
# - this could effectively hide the object's namespaces,vars etc from the caller (?)
return [set ::p::${this_OID}::_meta::map]
}
}
#upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls)
#incr c
#set reduce ::p::reducer${this_OID}_$c
set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance]
#puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args"
coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args
set current_ID_ $_ID_
set final 0
set result ""
while {$final == 0} {
#the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws)
set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command]
#puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'"
#if {[string match *Destroy $command]} {
# puts stdout " calling Destroy reduction_args:'$reduction_args'"
#}
if {$final == 1} {
if {[llength $command] == 1} {
if {$command eq "_exec_"} {
tailcall {*}$reduction_args
}
if {[llength [info commands $command]]} {
tailcall {*}$command $current_ID_ {*}$reduction_args
}
set cmdname [namespace tail $command]
set this_OID [lindex [dict get $current_ID_ i this] 0 0]
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} {
lset command 0 ::p::${this_OID}::(UNKNOWN)
tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg.
} else {
return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found"
}
} else {
#e.g lindex {a b c}
tailcall {*}$command {*}$reduction_args
}
} else {
if {[lindex $command 0] eq "_exec_"} {
set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]]
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ]
} else {
if {[llength $command] == 1} {
if {![llength [info commands $command]]} {
set cmdname [namespace tail $command]
set this_OID [lindex [dict get $current_ID_ i this] 0 0]
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} {
lset command 0 ::p::${this_OID}::(UNKNOWN)
set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
} else {
return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found"
}
} else {
#set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]]
set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]]
}
} else {
set result [uplevel 1 [list {*}$command {*}$reduction_args]]
}
if {[llength [info commands $result]]} {
if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} {
#looks like a pattern command
set current_ID_ [$result .. INVOCANTDATA]
#todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA
#if {![catch {$result .. INVOCANTDATA} result_invocantdata]} {
# set current_ID_ $result_invocantdata
#} else {
# return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object"
#}
} else {
#non-pattern command
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}]
}
} else {
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}]
#!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists)
}
}
}
}
error "Assert: Shouldn't get here (end of ::p::predator2)"
#return $result
}
package provide patternpredator2 1.2.8

4
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm

@ -8122,10 +8122,10 @@ namespace eval punk {
interp alias {} mode {} punk::mode
proc aliases {{glob *}} {
tailcall punk::lib::aliases $glob
tailcall punk::ns::aliases $glob
}
proc alias {{aliasorglob ""} args} {
tailcall punk::lib::alias $aliasorglob {*}$args
tailcall punk::ns::alias $aliasorglob {*}$args
}

4
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm

@ -108,8 +108,6 @@ tcl::namespace::eval punk::aliascore {
# the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were.
set aliases [tcl::dict::create\
val ::punk::pipe::val\
aliases ::punk::lib::aliases\
alias ::punk::lib::alias\
tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\
@ -138,6 +136,8 @@ tcl::namespace::eval punk::aliascore {
config ::punk::config\
s ::punk::ns::synopsis\
eg ::punk::ns::eg\
aliases ::punk::ns::aliases\
alias ::punk::ns::alias\
]
#*** !doctools

19
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm

@ -147,14 +147,18 @@ tcl::namespace::eval punk::ansi::class {
}]
method render_to_input_line {args} {
if {[llength $args] < 1} {
puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args
#puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
#punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args
punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line"
return
}
set x [lindex $args end]
set arglist [lrange $args 0 end-1]
if {[llength $arglist] %2 != 0} {
puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args
#puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x"
#punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args
punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line"
return
}
set opts [tcl::dict::create\
-dimensions 80x24\
@ -6076,12 +6080,13 @@ tcl::namespace::eval punk::ansi::ta {
}
#perl: ta_strip
punk::args::set_alias ::punk::ansi::ta::strip ::punk::ansi::ansistrip
proc strip {text} {
#*** !doctools
#[call [fun strip] [arg text]]
#[para]Return text stripped of Ansi codes
#[para]This is a tailcall to punk::ansi::ansistrip
tailcall ansistrip $text
tailcall punk::ansi::ansistrip $text
}
lappend PUNKARGS [list {
@ -6113,7 +6118,7 @@ tcl::namespace::eval punk::ansi::ta {
"Calculate length of text (excluding the ANSI codes)
This is not the printing length of the string on screen."
@values -min 1
text -type string
text -type string
} ]
#perl: ta_length
proc length {text} {
@ -6133,7 +6138,7 @@ tcl::namespace::eval punk::ansi::ta {
#perl: ta_trunc
#truncate $text to $width columns while still including all the ANSI colour codes.
proc trunc {text width args} {
error "unimplemented"
}
#not in perl ta

4
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm

@ -1,6 +1,6 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_::punk::ansi::colourmap 0 0.1.0]
#[manpage_begin punkshell_module_::punk::ansi::colourmap 0 0.1.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]

194
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm

@ -257,7 +257,7 @@ tcl::namespace::eval punk::args::register {
if {![info exists scanned_info]} {
set scanned_info [dict create]
}
#some packages, e.g punk::args::tclcore document other namespaces.
#some packages, e.g punk::args::moduledoc::tclcore document other namespaces.
#when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources
variable namespace_docpackages
if {![info exists namespace_docpackages]} {
@ -466,6 +466,8 @@ tcl::namespace::eval punk::args {
recognised types:
any
(unvalidated - accepts anything)
unknown
(unvalidated - accepts anything)
none
(used for flags/switches only. Indicates this is
a 'solo' flag ie accepts no value)
@ -475,6 +477,8 @@ tcl::namespace::eval punk::args {
number
list
indexexpression
indexset
(as accepted by punk::lib::is_indexset)
dict
double
float
@ -632,7 +636,7 @@ tcl::namespace::eval punk::args {
from existing definitions (by id) for re-use of argument specifications and help text)
e.g the following definition passes 2 blocks as text arguments
${[punk::args::tclcore::argdoc::example {
${[punk::args::moduledoc::tclcore::argdoc::example {
punk::args::define {
@id -id ::myns::myfunc
@cmd -name myns::myfunc -help\
@ -764,24 +768,25 @@ tcl::namespace::eval punk::args {
if {[dict exists $rawdef_cache $args]} {
return [dict get [dict get $rawdef_cache $args] -id]
} else {
set id [rawdef_id $args]
set lvl 2
set id [rawdef_id $args $lvl]
if {[id_exists $id]} {
#we seem to be re-creating a previously defined id...
#clear any existing caches for this id
puts stderr "punk::args::define Redefinition of id:$id - clearing existing data"
undefine $id 0
#dict unset argdata_cache $prevraw ;#silently does nothing if key not present
dict for {k v} $argdata_cache {
if {[dict get $v id] eq $id} {
dict unset argdata_cache $k
}
}
dict for {k v} $rawdef_cache {
if {[dict get $v -id] eq $id} {
dict unset rawdef_cache $k
}
}
dict unset id_cache_rawdef $id
##dict unset argdata_cache $prevraw ;#silently does nothing if key not present
#dict for {k v} $argdata_cache {
# if {[dict get $v id] eq $id} {
# dict unset argdata_cache $k
# }
#}
#dict for {k v} $rawdef_cache {
# if {[dict get $v -id] eq $id} {
# dict unset rawdef_cache $k
# }
#}
#dict unset id_cache_rawdef $id
}
set is_dynamic [rawdef_is_dynamic $args]
set defspace [uplevel 1 {::namespace current}]
@ -790,6 +795,35 @@ tcl::namespace::eval punk::args {
return $id
}
}
proc undefine {id {quiet 0}} {
variable rawdef_cache
variable id_cache_rawdef
variable argdata_cache
if {[id_exists $id]} {
if {!$quiet} {
puts stderr "punk::args::undefine clearing existing data for id:$id"
}
dict for {k v} $argdata_cache {
if {[dict get $v id] eq $id} {
dict unset argdata_cache $k
}
}
dict for {k v} $rawdef_cache {
if {[dict get $v -id] eq $id} {
dict unset rawdef_cache $k
}
}
dict unset id_cache_rawdef $id
} else {
if {!$quiet} {
puts stderr "punk::args::undefine unable to find id: '$id'"
}
}
}
#'punk::args::parse $args withdef $deflist' can raise parsing error after an autoid was generated
# In this case we don't see the autoid in order to delete it
#proc undefine_deflist {deflist} {
#}
proc idquery_info {id} {
variable id_cache_rawdef
@ -889,7 +923,8 @@ tcl::namespace::eval punk::args {
set textargs $args
if {![llength $args]} {
punk::args::get_by_id ::punk::args::define {}
#punk::args::get_by_id ::punk::args::define {}
punk::args::parse {} -errorstyle minimal withid ::punk::args::define
return
}
#if {[lindex $args 0] eq "-dynamic"} {
@ -1184,7 +1219,7 @@ tcl::namespace::eval punk::args {
}
ref {
#a reference within the definition
#e.g see punk::args::tclcore ::after
#e.g see punk::args::moduledoc::tclcore ::after
#global reference dict - independent of forms
#ignore refs without an -id
#store all keys except -id
@ -1952,6 +1987,7 @@ tcl::namespace::eval punk::args {
char - character {set normtype char}
dict - dictionary {set normtype dict}
index - indexexpression {set normtype indexexpression}
indexset {set normtype indexset}
"" - none - solo {
if {$is_opt} {
#review - are we allowing clauses for flags?
@ -1975,6 +2011,10 @@ tcl::namespace::eval punk::args {
}
}
any - anything {set normtype any}
unknown {
#'unspecified' ??
set normtype unknown
}
ansi - ansistring {set normtype ansistring}
string - globstring {set normtype $lc_firstword}
literal {
@ -2705,25 +2745,38 @@ tcl::namespace::eval punk::args {
#@dynamic only has meaning as 1st element of a def in the deflist
}
#@id must be within first 4 lines of a block - or assign auto
#@id must be within first 4 lines of first 3 blocks - or assign auto
#review - @dynamic block where -id not explicitly set? - disallow?
proc rawdef_id {rawdef} {
proc rawdef_id {rawdef {lvl 1}} {
set id ""
foreach d $rawdef {
set found_id_line 0
foreach d [lrange $rawdef 0 2] {
foreach ln [lrange [split $d \n] 0 4] {
if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} {
if {$firstword eq "@id"} {
set found_id_line 1
#review - uplevel 2 would be a call from punk::args::define ??
set rest [uplevel $lvl [list punk::args::lib::tstr -allowcommands $rest]]
if {[llength $rest] %2 == 0 && [dict exists $rest -id]} {
set id [dict get $rest -id]
break
}
break
}
}
}
if {$id ne ""} {
if {$found_id_line} {
break
}
}
if {$id eq "" && $found_id_line} {
#Looked like an @id - but presumable the rest of the line was malformed.
#we won't produce an autoid for such a definition.
set first3blocks ""
foreach b [lrange $rawdef 0 2] {
append first3blocks $b\n
}
error "punk::args::rawdef_id found an @id line in the first 4 lines of one of the 1st 3 blocks - but failed to retrieve a value for it.\nraw_def 1st 3 blocks:\n$first3blocks"
}
if {$id eq "" || [string tolower $id] eq "auto"} {
variable id_counter
set id "autoid_[incr id_counter]"
@ -2916,7 +2969,9 @@ tcl::namespace::eval punk::args {
set seen_documentedns [list] ;#seen per pkgns
foreach definitionlist [set ${pkgns}::PUNKARGS] {
#namespace eval $evalns [list punk::args::define {*}$definitionlist]
set id [rawdef_id $definitionlist]
#set id [rawdef_id $definitionlist]
set lvl 1 ;#level at which tstr substitution occurs in @id line
set id [namespace eval $pkgns [list punk::args::rawdef_id $definitionlist $lvl]]
if {[string match autoid_* $id]} {
puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping"
puts stderr "definition:\n"
@ -2958,6 +3013,9 @@ tcl::namespace::eval punk::args {
} else {
set needed [list]
foreach pkgns $nslist {
if {[string match (autodef)* $pkgns]} {
set pkgns [string range $pkgns 9 end]
}
if {![string match ::* $pkgns]} {
puts stderr "warning: update_definitions received unqualified ns: $pkgns"
set pkgns ::$pkgns
@ -3443,18 +3501,28 @@ tcl::namespace::eval punk::args {
set docname [Dict_getdef $spec_dict doc_info -name "Manual:"]
set docurl [Dict_getdef $spec_dict doc_info -url ""]
#set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""]
#set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""]
#if {"$argdisplay_header$argdisplay_body" eq ""} {
# set is_custom_argdisplay 0
#} else {
# set is_custom_argdisplay 1
#}
#temp - TODO
#review - when can there be more than one selected form?
set argdisplay_header ""
set argdisplay_body ""
set is_custom_argdisplay 0
if {[llength $selected_forms] == 1} {
set fid [lindex $selected_forms 0]
set FRM [dict get $spec_dict FORMS $fid]
if {[dict size [dict get $FRM FORMDISPLAY]]} {
set argdisplay_header [Dict_getdef $FRM FORMDISPLAY -header ""]
set argdisplay_body [Dict_getdef $FRM FORMDISPLAY -body ""]
}
}
# if {![dict size $F $fid $FORMDISPLAY]} {}
#set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""]
#set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""]
if {"$argdisplay_header$argdisplay_body" eq ""} {
set is_custom_argdisplay 0
} else {
set is_custom_argdisplay 1
}
#set is_custom_argdisplay 0
set blank_header_col [list]
@ -4335,7 +4403,7 @@ tcl::namespace::eval punk::args {
documentation generated dynamically and may not yet have an id.
IDs for autogenenerated help are prefixed e.g (autodef)::myensemble.
Generally punk::ns::arginfo (aliased as i in the punk shell) should
Generally punk::ns::cmdhelp (aliased as i in the punk shell) should
be used in preference - as it will search for a documentation
mechanism and call punk::args::usage as necessary.
"
@ -5730,6 +5798,15 @@ tcl::namespace::eval punk::args {
break
}
}
indexset {
if {![punk::lib::is_indexset $e_check]} {
set msg "$argclass $argname for %caller% requires type indexset. A comma-delimited set of indexes or index-ranges separated by '..' Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
} else {
lset clause_results $c_idx $a_idx 1
break
}
}
string - ansistring - globstring {
#we may commonly want exceptions that ignore validation rules - most commonly probably the empty string
#we possibly don't want to always have to regex on things that don't pass the other more basic checks
@ -8729,7 +8806,7 @@ tcl::namespace::eval punk::args {
}
set type_expression [string trim $typespec ?]
if {$type_expression in {any none}} {
if {$type_expression in {any none unknown}} {
continue
}
#puts "$argname - switch on type_expression: $type_expression v:[lindex $vlist $clausecolumn]"
@ -8790,7 +8867,8 @@ tcl::namespace::eval punk::args {
dict set finalopts $o $v
}
}
return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived]
set docid [dict get $argspecs id]
return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived id $docid]
}
lappend PUNKARGS [list {
@ -9570,8 +9648,15 @@ tcl::namespace::eval punk::args {
}
}
set cinfo [punk::ns::resolve_command {*}$cmd]
set tp [dict get $cinfo cmdtype]
#don't use full cmdinfo if $cmd is a single element
if {[llength $cmd] == 1} {
set cinfo [punk::ns::cmdwhich $cmd]
set tp [dict get $cinfo whichtype]
} else {
puts stderr "WARNING ==ensemble_subcommands_definition== cmdinfo $cmd\n$cinfo"
set cinfo [punk::ns::cmdinfo {*}$cmd]
set tp [dict get $cinfo cmdtype]
}
dict set choiceinfodict $sc [list [list resolved $cmd]]
@ -9584,9 +9669,23 @@ tcl::namespace::eval punk::args {
}
}
if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} {
#could be more than one punk::args id - choose a precedence by how we order the id_exists checks.
if {[punk::args::id_exists [list $ensemble $sc]]} {
dict lappend choiceinfodict $sc {doctype punkargs}
dict lappend choiceinfodict $sc [list subhelp {*}$ensemble $sc]
} elseif {[punk::args::id_exists $cmd]} {
dict lappend choiceinfodict $sc {doctype punkargs}
dict lappend choiceinfodict $sc [list subhelp {*}$cmd]
} elseif {[punk::args::id_exists [dict get $cinfo origin]]} {
dict lappend choiceinfodict $sc {doctype punkargs}
dict lappend choiceinfodict $sc [list subhelp {*}[dict get $cinfo origin]]
} else {
#puts stderr "ensemble_subcommands_definition--- NO doc for [list $ensemble $sc] or $cmd or [dict get $cinfo origin]"
}
#if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} {
# dict lappend choiceinfodict $sc {doctype punkargs}
#}
}
set argdef ""
@ -9699,9 +9798,18 @@ tcl::namespace::eval punk::args::lib {
ooc {
lappend marks [punk::ns::Cmark ooc cyan]
}
classmethod {
lappend marks [punk::ns::Cmark classmethod term-orange1]
}
coremethod {
lappend marks [punk::ns::Cmark coremethod term-plum1]
}
ooo {
lappend marks [punk::ns::Cmark ooo cyan]
}
objectmethod {
lappend marks [punk::ns::Cmark objectmethod term-orange1]
}
native {
lappend marks [punk::ns::Cmark native]
}
@ -9724,11 +9832,11 @@ tcl::namespace::eval punk::args::lib {
@id -id ::punk::args::lib::tstr
@cmd -name punk::args::lib::tstr\
-summary\
"Templating with \$\{$varName\}"\
"Templating with placeholders such as: \$\{$varName\}"\
-help\
"A rough equivalent of js template literals
"Roughly analogous to js template literals
Substitutions:
Placeholder Substitutions:
\$\{$varName\}
\$\{[myCommand]\}
(when -allowcommands flag is given)"

7031
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm

File diff suppressed because it is too large Load Diff

195
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm

@ -4988,7 +4988,8 @@ tcl::namespace::eval punk::args::tclcore {
obsolete {variable vdelete vinfo}
}\
-choiceinfo {
add {{doctype punkargs} {subhelp ::trace add}}
add {{doctype punkargs} {subhelp ::trace add}}
remove {{doctype punkargs} {subhelp ::trace remove}}
}
@values -min 0 -max 0
@ -4996,23 +4997,30 @@ tcl::namespace::eval punk::args::tclcore {
punk::args::define {
@id -id "::trace add"
@cmd -name "Built-in: trace add" -help\
""
@cmd -name "Built-in: trace add"\
-summary\
"Add a command, execution or variable trace."\
-help\
"Add a command, execution or variable trace."
@form -synopsis "trace add type name ops ?args?"
@leaders
type -choicegroups {
"" {command execution variable}
}\
-choiceinfo {
command {{doctype punkargs}}
execution {{doctype punkargs}}
command {{doctype punkargs} {subhelp ::trace add command}}
execution {{doctype punkargs} {subhelp ::trace add execution}}
variable {{doctype punkargs}}
}
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace add command"
@cmd -name "Built-in: trace add command" -help\
@cmd -name "Built-in: trace add command"\
-summary\
"Add command trace for operation(s): rename delete"\
-help\
"Arrange for commandPrefix to be executed (with additional arguments)
whenever command name is modified in one of the ways given by the list
ops. Name will be resolved using the usual namespace resolution rules
@ -5056,10 +5064,126 @@ tcl::namespace::eval punk::args::tclcore {
"
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace add variable"
@cmd -name "Built-in: trace add variable"\
-summary\
"Add variable trace for operation(s): array read write unset."\
-help\
"Arrange for commandPrefix to be executed whenever variable name is accessed
in one of the ways given by the list ops. Name may refer to a normal variable,
an element of an array, or to an array as a whole (i.e. name may be just the
name of an array, with no parenthesized index). If name refers to a whole
array, then commandPrefix is invoked whenever any element of the array is
manipulated. If the variable does not exist, it will be created but will not
be given a value, so it will be visible to namespace which queries, but not to
info exists queries."
name -type string -help\
"Name of variable"
# ---------------------------------------------------------------
ops -type list -choices {array read write unset} -choiceprefix 0\
-choicemultiple {1 4}\
-choicecolumns 1\
-choicelabels {
array\
" Invoke commandPrefix whenever the variable is accessed or
modified via the array command, provided that name is not a
scalar variable at the time that the array command is invoked.
If name is a scalar variable, the access via the array command
will not trigger the trace."
read\
" Invoke commandPrefix whenever the variable isread."
write\
" Invoke commandPrefix whenever the variable is written."
unset\
" Invoke commandPrefix whenever the variable is unset. Variables
can be unset explicitly with the unset command, or implicitly
when procedures return (all of their local variables are unset).
Variables are also unset when interpreters are deleted, but
traces will not be invoked because there is no interpreter in
which to execute them."
}\
-help\
"Indicates which operations are of interest."
commandPrefix -type string -help\
"When the trace triggers, three arguments are appended to commandPrefix
so that the actual command is as follows:
-----------------------------------------
commandPrefix name1 name2 op
-----------------------------------------
Name1 gives the name for the variable being accessed. This is not
necessarily the same as the name used in the trace add variable command:
the upvar command allows a procedure to reference a variable under a
different name. If the trace was originally set on an array or array
element, name2 provides which index into the array was affected. This
information is present even when name1 refers to a scalar, which may
happen if the upvar command was used to create a reference to a single
array element. If an entire array is being deleted and the trace was
registered on the overall array, rather than a single element, then
name1 gives the array name and name2 is an empty string. Op indicates
what operation is being performed on the variable, and is one of read,
write, or unset as defined above.
CommandPrefix executes in the same context as the code that invoked the
traced operation: if the variable was accessed as part of a Tcl procedure,
then commandPrefix will have access to the same local variables as code in
the procedure. This context may be different than the context in which the
trace was created. If commandPrefix invokes a procedure (which it normally
does) then the procedure will have to use upvar or uplevel if it wishes to
access the traced variable. Note also that name1 may not necessarily be
the same as the name used to set the trace on the variable; differences
can occur if the access is made through a variable defined with the upvar
command.
For read and write traces, commandPrefix can modify the variable to affect
the result of the traced operation. If commandPrefix modifies the value of
a variable during a read or write trace, then the new value will be
returned as the result of the traced operation. The return value from
commandPrefix is ignored except that if it returns an error of any sort
then the traced operation also returns an error with the same error message
returned by the trace command (this mechanism can be used to implement
read-only variables, for example). For write traces, commandPrefix is
invoked after the variable's value has been changed; it can write a new
value into the variable to override the original value specified in the
write operation. To implement read-only variables, commandPrefix will have
to restore the old value of the variable.
While commandPrefix is executing during a read or write trace, traces on
the variable are temporarily disabled. This means that reads and writes
invoked by commandPrefix will occur directly, without invoking
commandPrefix (or any other traces) again. However, if commandPrefix
unsets the variable then unset traces will be invoked.
When an unset trace is invoked, the variable has already been deleted: it
will appear to be undefined with no traces. If an unset occurs because of
a procedure return, then the trace will be invoked in the variable context
of the procedure being returned to: the stack frame of the returning
procedure will no longer exist. Traces are not disabled during unset
traces, so if an unset trace command creates a new trace and accesses the
variable, the trace will be invoked. Any errors in unset traces are ignored.
If there are multiple traces on a variable they are invoked in order of
creation, most-recent first. If one trace returns an error, then no further
traces are invoked for the variable. If an array element has a trace set,
and there is also a trace set on the array as a whole, the trace on the
overall array is invoked before the one on the element.
Once created, the trace remains in effect either until the trace is removed
with the trace remove variable command described below, until the variable
is unset, or until the interpreter is deleted. Unsetting an element of array
will remove any traces on that element, but will not remove traces on the
overall array.
This command returns an empty string."
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace add execution"
@cmd -name "Built-in: trace add execution" -help\
@cmd -name "Built-in: trace add execution"\
-summary\
"Add execution trace for operation(s): enter leave enterstep leavestep."\
-help\
"Arrange for commandPrefix to be executed (with additional arguments)
whenever command name is executed, with traces occurring at the points
indicated by the list ops. Name will be resolved using the usual namespace
@ -5159,6 +5283,25 @@ tcl::namespace::eval punk::args::tclcore {
"
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace remove"
@cmd -name "Built-in: trace remove"\
-summary\
"Remove a command, execution or variable trace."\
-help\
"Remove a command, execution or variable trace."
@form -synopsis "trace remove type name ops ?args?"
@leaders
type -choicegroups {
"" {command execution variable}
}\
-choiceinfo {
command {{doctype punkargs} {subhelp ::trace remove command}}
execution {{doctype punkargs} {subhelp ::trace remove execution}}
variable {{doctype punkargs} {subhelp ::trace remove variable}}
}
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace remove command"
@cmd -name "Built-in: trace remove command" -help\
@ -5175,6 +5318,44 @@ tcl::namespace::eval punk::args::tclcore {
delete"
commandPrefix
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace remove execution"
@cmd -name "Built-in: trace remove execution" -help\
"If there is a trace set on command name with the operations and command
given by opList and commandPrefix, then the trace is removed, so that
commandPrefix will never again be invoked. Returns an empty string. If
name does not exist, the command will throw an error"
@values
name -type string -help\
"Name of command"
opList -type list -help\
"A list of one or more of the following items:
enter
leave
enterstep
leavestep"
commandPrefix
} "@doc -name Manpage: -url [manpage_tcl trace]"
punk::args::define {
@id -id "::trace remove variable"
@cmd -name "Built-in: trace remove variable" -help\
"If there is a trace set on command name with the operations and command
given by opList and commandPrefix, then the trace is removed, so that
commandPrefix will never again be invoked. Returns an empty string."
@values
name -type string -help\
"Name of command"
opList -type list -help\
"A list of one or more of the following items:
array
read
write
unset"
commandPrefix
} "@doc -name Manpage: -url [manpage_tcl trace]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---

123
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm

@ -66,12 +66,14 @@ namespace eval punk::cap::handlers::templates {
set multivendor_package_whitelist [list punk::mix::templates]
#for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the projectbase rather than rechecking it each time the templates handler api is called
#for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the base rather than rechecking it each time the templates handler api is called
#for template pathtype absolute - we can do the same.
#There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change.
#adhoc and currentproject* paths are relative to cwd - so no projectbase information can be stored at registration time.
#not all template item types will need projectbase information - as the item data may be self-contained within the template structure -
#adhoc and currentproject* pathtypes are relative to cwd - so no base information can be stored at registration time.
#module pathtype base is resolved by the providing package itself at load time using 'info script'
#not all template item types will need base information - as the item data may be self-contained within the template structure -
#but project_layout will need it - or at least need to know if there is no project - because project_layout data is never stored in the template folder structure directly.
switch -- $pathtype {
adhoc {
@ -86,44 +88,19 @@ namespace eval punk::cap::handlers::templates {
if {[file pathtype $path] ne "relative"} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
}
#todo - check for mounted modpod (or tarjar?)
#e.g //zipfs:/#modpod/d1/d2/#mounted-modpod-libname-V.v
#(or equivalent for vfs eg c:/repo/jn/shellspy/modules/test/#modpod/test/#mounted-modpod-libname-V.v
set provide_statement [package ifneeded $pkg [package require $pkg]]
set tmfile [lindex $provide_statement end]
if {[interp issafe]} {
#default safe interp can't use file exists/normalize etc.. but safe interp may have a policy/alias set allowing file access to certain paths - so test if file exists is usable
if {[catch {file exists $tmfile} tm_exists]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING (expected in most safe interps) - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
flush stderr
return 0
}
} else {
set tm_exists [file exists $tmfile]
}
if {!$tm_exists} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
flush stderr
#The package should have provided a base folder (by using 'info script') when it was loaded
#'package ifneeded' for a module gives initial path information for a package - but it might redirect to sourcing from a different location such as being mounted elsewhere in a vfs,
#in which case we wouldn't get the correct path.
if {![dict exists $capdict base]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing the 'base' key (required when pathtype is 'module')"
return 0
}
set tmfolder [file dirname $tmfile]
#todo - handle wrapped or unwrapped tarjar files - in which case we have to adjust tmfolder appropriately
#set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder
#set projectinfo [punk::repo::find_repos $tmfolder] ;#slow - REVIEW
#REVIEW - do we even want project base relative to where the lib came from??
#should be relative to executable? or cwd?
set projectbase [punk::repo::find_project $tmfolder]
#store the projectbase even if it's empty string
set extended_capdict $capdict
set resolved_path [file join $tmfolder $path]
set base [dict get $capdict base]
set resolved_path [file join $base $path]
dict set extended_capdict resolved_path $resolved_path
dict set extended_capdict projectbase $projectbase
dict set extended_capdict base $base
}
currentproject_multivendor {
#currently only intended for punk::mix::templates - review if 3rd party _multivendor trees even make sense
@ -156,14 +133,18 @@ namespace eval punk::cap::handlers::templates {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
return 0
}
set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
#set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
set shellbase [file dirname [file dirname [file normalize [info nameofexecutable]/___]]]
#set projectinfo [punk::repo::find_repos $shellbase]
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $shellbase]
#set base [dict get $projectinfo closest]
#may result in empty base for no project found
set base [punk::repo::find_project $shellbase]
set extended_capdict $capdict
dict set extended_capdict vendor $vendor
dict set extended_capdict projectbase $projectbase
dict set extended_capdict base $base
}
shellproject_multivendor {
#currently only intended for punk::templates - review if 3rd party _multivendor trees even make sense
@ -175,14 +156,15 @@ namespace eval punk::cap::handlers::templates {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
return 0
}
set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
#set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
set shellbase [file dirname [file dirname [file normalize [info nameofexecutable]/___]]]
#set projectinfo [punk::repo::find_repos $shellbase]
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $shellbase]
#set base [dict get $projectinfo closest]
set base [punk::repo::find_project $shellbase]
set extended_capdict $capdict
dict set extended_capdict vendor $vendor
dict set extended_capdict projectbase $projectbase
dict set extended_capdict base $base
}
absolute {
if {[file pathtype $path] ne "absolute"} {
@ -194,15 +176,12 @@ namespace eval punk::cap::handlers::templates {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' which doesn't seem to exist"
return 0
}
#set projectinfo [punk::repo::find_repos $normpath]
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $normpath]
#todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder
set extended_capdict $capdict
dict set extended_capdict resolved_path $normpath
dict set extended_capdict vendor $vendor
dict set extended_capdict projectbase $projectbase
dict set extended_capdict base ""
}
default {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' with unrecognised type $pathtype"
@ -332,16 +311,16 @@ namespace eval punk::cap::handlers::templates {
set path [dict get $capdecl_extended path]
set pathtype [dict get $capdecl_extended pathtype]
set vendor [dict get $capdecl_extended vendor]
# projectbase not present in capdecl_extended for all template pathtypes
# base not present in capdecl_extended for all template pathtypes ?
if {$pathtype eq "adhoc"} {
#e.g (cwd)/templates
set targetpath [file join $startdir [dict get $capdecl_extended path]]
if {[file isdirectory $targetpath]} {
dict lappend found_paths_adhoc $vendor [list pkg $pkg path $targetpath pathtype $pathtype]
dict lappend found_paths_adhoc $vendor [list pkg $pkg path $targetpath pathtype $pathtype base $startdir]
}
} elseif {$pathtype eq "module"} {
set module_projectroot [dict get $capdecl_extended projectbase]
dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot]
set mbase [dict get $capdecl_extended base]
dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype base $mbase]
} elseif {$pathtype eq "currentproject_multivendor"} {
#set searchbase $startdir
#set pathinfo [punk::repo::find_repos $searchbase]
@ -357,11 +336,11 @@ namespace eval punk::cap::handlers::templates {
set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *]
foreach vf $vendorfolders {
if {$vf ne "_project"} {
dict lappend found_paths_currentproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype]
dict lappend found_paths_currentproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype base $pwd_projectroot]
}
}
if {[file isdirectory [file join $vendorbase _project]]} {
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype]
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype base $pwd_projectroot]
}
}
set custombase [file join $deckbase custom]
@ -369,11 +348,11 @@ namespace eval punk::cap::handlers::templates {
set customfolders [glob -nocomplain -dir $custombase -type d -tails *]
foreach cf $customfolders {
if {$cf ne "_project"} {
dict lappend found_paths_currentproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype]
dict lappend found_paths_currentproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype base $pwd_projectroot]
}
}
if {[file isdirectory [file join $custombase _project]]} {
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype]
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype base $pwd_projectroot]
}
}
}
@ -385,7 +364,7 @@ namespace eval punk::cap::handlers::templates {
#path relative to projectroot already validated by handler as being within a currentproject_multivendor tree
set targetfolder [file join $pwd_projectroot $path]
if {[file isdirectory $targetfolder]} {
dict lappend found_paths_currentproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype]
dict lappend found_paths_currentproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype base $pwd_projectroot]
}
}
} elseif {$pathtype eq "shellproject_multivendor"} {
@ -394,7 +373,7 @@ namespace eval punk::cap::handlers::templates {
#set pathinfo [punk::repo::find_repos $shellbase]
#set pwd_projectroot [dict get $pathinfo closest]
set shell_projectroot [dict get $capdecl_extended projectbase]
set shell_projectroot [dict get $capdecl_extended base]
if {$shell_projectroot ne ""} {
set deckbase [file join $shell_projectroot $path]
if {![file exists $deckbase]} {
@ -406,11 +385,11 @@ namespace eval punk::cap::handlers::templates {
set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *]
foreach vf $vendorfolders {
if {$vf ne "_project"} {
dict lappend found_paths_shellproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype base $shell_projectroot]
}
}
if {[file isdirectory [file join $vendorbase _project]]} {
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype base $shell_projectroot]
}
}
set custombase [file join $deckbase custom]
@ -418,11 +397,11 @@ namespace eval punk::cap::handlers::templates {
set customfolders [glob -nocomplain -dir $custombase -type d -tails *]
foreach cf $customfolders {
if {$cf ne "_project"} {
dict lappend found_paths_shellproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype base $shell_projectroot]
}
}
if {[file isdirectory [file join $custombase _project]]} {
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype base $shell_projectroot]
}
}
@ -434,17 +413,17 @@ namespace eval punk::cap::handlers::templates {
#set pathinfo [punk::repo::find_repos $shellbase]
#set pwd_projectroot [dict get $pathinfo closest]
set shell_projectroot [dict get $capdecl_extended projectbase]
set shell_projectroot [dict get $capdecl_extended base]
if {$shell_projectroot ne ""} {
set targetfolder [file join $shell_projectroot $path]
if {[file isdirectory $targetfolder]} {
dict lappend found_paths_shellproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype projectbase $shell_projectroot]
dict lappend found_paths_shellproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype base $shell_projectroot]
}
}
} elseif {$pathtype eq "absolute"} {
#lappend found_paths [dict get $capdecl_extended resolved_path]
set abs_projectroot [dict get $capdecl_extended projectbase]
dict lappend found_paths_absolute $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $abs_projectroot]
set abs_projectroot [dict get $capdecl_extended base]
dict lappend found_paths_absolute $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype base $abs_projectroot]
}
}
@ -460,19 +439,19 @@ namespace eval punk::cap::handlers::templates {
dict for {vendor pathinfolist} $found_paths_module {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor]
}
}
#Templates within project of shell we launched with has lower priority than 'currentproject' (which depends on our CWD)
dict for {vendor pathinfolist} $found_paths_shellproject_multivendor {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor]
}
}
dict for {vendor pathinfolist} $found_paths_shellproject {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor]
}
}
@ -488,7 +467,7 @@ namespace eval punk::cap::handlers::templates {
}
dict for {vendor pathinfolist} $found_paths_absolute {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] base [dict get $pathinfo base] vendor $vendor]
}
}
#adhoc paths relative to cwd (or specified -startdir) can override any
@ -540,9 +519,9 @@ namespace eval punk::cap::handlers::templates {
set tailats [join [lrange $atparts 1 end] @]
# @ parts after the first are part of the path within the project_layouts structure
set subpathlist [split $tailats +]
if {[dict exists $refinfo sourceinfo projectbase]} {
if {[dict exists $refinfo sourceinfo base]} {
#some template pathtypes refer to the projectroot from the template - not the cwd
set ref_projectroot [dict get $refinfo sourceinfo projectbase]
set ref_projectroot [dict get $refinfo sourceinfo base]
} else {
set ref_projectroot $projectroot
}

143
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm

@ -497,78 +497,6 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}]
}
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed)
proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
set ns_mapped [string map {:: \uFFFF} $ns]
#puts stderr "aliases ns: $ns_mapped"
set segments [split $ns_mapped \uFFFF] ;#include empty string before leading ::
if {![string length [lindex $segments end]]} {
#special case for :: only include leading segment rather thatn {} {}
set segments [lrange $segments 0 end-1]
}
set segcount [llength $segments] ;#only match number of segments matching current ns
set all_aliases [interp aliases {}]
set matched [list]
foreach a $all_aliases {
#normalize with leading ::
if {![string match ::* $a]} {
set abs ::$a
} else {
set abs $a
}
set asegs [split [string map {:: \uFFFF} $abs] \uFFFF]
set acount [llength $asegs]
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments"
if {($acount - 1) == $segcount} {
if {[lrange $asegs 0 end-1] eq $segments} {
if {[string match $glob [lindex $asegs end]]} {
#report this alias in the current namespace - even though there may be no matching command
lappend matched $a ;#add raw alias token which may or may not have leading ::
}
}
}
}
#set matched_abs [lsearch -all -inline $all_aliases $glob]
return $matched
}
proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
if {[llength $args]} {
if {$aliasorglob in [interp aliases ""]} {
set existing [interp alias "" $aliasorglob]
puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)"
}
if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} {
#use empty string/whitespace as intention to delete alias
return [interp alias "" $aliasorglob ""]
}
return [interp alias "" $aliasorglob "" {*}$args]
} else {
if {![string length $aliasorglob]} {
set aliaslist [punk::lib::aliases]
puts -nonewline stderr $aliaslist
return
}
#we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias
set target [interp alias "" $aliasorglob]
if {[llength $target]} {
return $target
}
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} {
set aliaslist [punk::lib::aliases $aliasorglob]
puts -nonewline stderr $aliaslist
return
}
return [list]
}
}
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
@ -2242,7 +2170,51 @@ namespace eval punk::lib {
}
}
punk::args::define {
@id -id ::punk::lib::is_indexset
@cmd -name punk::lib::is_indexset\
-summary\
"Validate string is a comma-delimited 'indexset'."\
-help\
"Validate that a string is an 'indexset'
An indexset consists of a comma delimited list of indexes or index-ranges.
The indexes are 0-based.
Ranges must be specified with .. as the separator.
Common whitespace elements space,tab,newlines are ignored.
Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands,
e.g end-2 or 2+2.
see indexset_resolve"
@values -min 2 -max 2
indexset -type string
}
proc is_indexset {indexset} {
#collapse internal whitespace (for basic whitespace set we allow)
set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset]
if {![regexp {^[\-\+_end,\.0-9]*$} $indexset]} {
return 0
}
set ranges [split $indexset ,]
foreach r $ranges {
set validateindices [list]
set rposn [string first .. $r]
if {$rposn >= 0} {
lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end]
} else {
#'range' is just an index
set validateindices [list $r]
}
foreach v $validateindices {
if {$v eq "" || $v eq "end"} {continue}
if {[string is integer -strict $v]} {continue}
if {[catch {lindex {} $v}]} {
return 0
}
}
}
return 1
}
#review - compare to IMAP4 methods of specifying ranges?
punk::args::define {
@id -id ::punk::lib::indexset_resolve
@ -2251,6 +2223,8 @@ namespace eval punk::lib {
"Resolve an indexset to a list of integers based on supplied list or string length."\
-help\
"Resolve an 'indexset' to a list of actual indices within the range of the provided numitems value.
e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9
An indexset consists of a comma delimited list of indexes or index-ranges.
The indexes are 0-based.
Ranges must be specified with .. as the separator.
@ -2258,27 +2232,30 @@ namespace eval punk::lib {
Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands,
e.g end-2 or 2+2.
end means the last page.
end-1 means the second last page.
end means the last item.
end-1 means the second last item.
0.. is the same as 0..end.
examples:
indexset examples:
1,3..
output the page index 1 (2nd page) followed by all from index 3 to the end.
output the index 1 (2nd item) followed by all from index 3 to the end.
'indexset_resolve 4 1,3..' -> 1 3
'indexset_resolve 10 1,3..' -> 1 3 4 5 6 7 8 9
0-2,end
output the first 3 pages, and the last page.
output the first 3 indices, and the last index.
end-1..0
output the indexes in reverse order from 2nd last page to first page."
output the indexes in reverse order from 2nd last item to first item."
@values -min 2 -max 2
numitems -type integer
indexset -type string
indexset -type indexset -help "comma delimited specification for indices to return"
}
proc indexset_resolve {numitems indexset} {
if {![string is integer -strict $numitems] || ![regexp {^[\-\+_end,\.0-9]*$} $indexset]} {
if {![string is integer -strict $numitems] || ![is_indexset $indexset]} {
#use parser on unhappy path only
set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve]
uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg]
}
set index_list [list] ;#list of actual indexes within the range
}
set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace
set index_list [list] ;#list of actual indexes within the range
set iparts [split $indexset ,]
set index_list [list]
foreach ipart $iparts {
@ -2286,7 +2263,7 @@ namespace eval punk::lib {
set rposn [string first .. $ipart]
if {$rposn>=0} {
#range
lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb
lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb
set rawa [string trim $rawa]
set rawb [string trim $rawb]
if {$rawa eq ""} {set rawa 0}

4
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm

@ -1,5 +1,5 @@
# -*- tcl -*-
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
@ -17,7 +17,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::libunknown 0 0.1]
#[manpage_begin punkshell_module_punk::libunknown 0 0.1]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]

5
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix-0.2.tm

@ -7,6 +7,11 @@ tcl::namespace::eval punk::mix {
package require punk::cap::handlers::templates ;#handler for templates cap
punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us
#todo: use tcllib pluginmgr to load all modules that provide 'punk.templates'
#review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages
#We may also need to better control the order of module and library paths in the safe interps pluginmgr uses.
#todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation)
package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap
set t [time {
if {[catch {punk::mix::templates::provider register *} errM]} {

14
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm

@ -480,7 +480,7 @@ namespace eval punk::mix::cli {
}
#repotypes *could* be both git and fossil - so report both if so
if {"git" in $repotypes} {
append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n
append result "\nGIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n
if {[string length [set git_prog [auto_execok git]]]} {
set git_remotes [exec {*}$git_prog remote -v]
append result $git_remotes
@ -791,10 +791,10 @@ namespace eval punk::mix::cli {
if {[catch {
file copy -force $modulefile $target_module_dir
} errMsg]} {
puts stderr "FAILED to copy zip modpod module $modulefile to $target_module_dir"
puts stderr "[punk::ansi::a+ red]FAILED to copy zip modpod module $modulefile to $target_module_dir[punk::ansi::a]"
$event targetset_end FAILED -note "could not copy $modulefile"
} else {
puts stderr "Copied zip modpod module $modulefile to $target_module_dir"
puts stderr "[punk::ansi::a+ green]Copied zip modpod module $modulefile to $target_module_dir[punk::ansi::a]"
# -- --- --- --- --- ---
$event targetset_end OK -note "zip modpod"
}
@ -821,7 +821,7 @@ namespace eval punk::mix::cli {
if {$tmfile_versionsegment eq $magicversion} {
set versionfiledata ""
if {![file exists $versionfile]} {
puts stderr "\nWARNING: Missing buildversion text file: $versionfile"
puts stderr "\n[punk::ansi::a+ brightyellow]WARNING: Missing buildversion text file: $versionfile[punk::ansi::a]"
puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n"
set module_build_version "0.1"
} else {
@ -830,7 +830,7 @@ namespace eval punk::mix::cli {
set ln0 [lindex [split $versionfiledata \n] 0]
set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r]
if {![util::is_valid_tm_version $ln0]} {
puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file"
puts stderr "ERROR:[punk::ansi::a+ red] build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file[punk::ansi::a]"
exit 3
}
set module_build_version $ln0
@ -973,10 +973,10 @@ namespace eval punk::mix::cli {
if {[catch {
file copy -force $modulefile $target_module_dir
} errMsg]} {
puts stderr "FAILED to copy tarjar module $modulefile to $target_module_dir"
puts stderr "[punk::ansi::a+ red]FAILED to copy tarjar module $modulefile to $target_module_dir[punk::ansi::a]"
$event targetset_end FAILED -note "could not copy $modulefile"
} else {
puts stderr "Copied tarjar module $modulefile to $target_module_dir"
puts stderr "[punk::ansi::a+ green]Copied tarjar module $modulefile to $target_module_dir[punk::ansi::a]"
# -- --- --- --- --- ---
$event targetset_end OK -note "tarjar"
}

BIN
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/templates-0.1.2.tm

Binary file not shown.

3414
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm

File diff suppressed because it is too large Load Diff

2
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm

@ -328,7 +328,7 @@ tcl::namespace::eval punk::packagepreference {
catch {
#$COMMANDSTACKNEXT require $pkg {*}$vwant
#j2
$COMMANDSTACKNEXT require punk::args::$dp
$COMMANDSTACKNEXT require punk::args::moduledoc::$dp
}
}
#---------------------------------------------------------------

54
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/pipe-1.0.tm

@ -1,6 +1,6 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::pipe 0 1.0]
#[manpage_begin punkshell_module_punk::pipe 0 1.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
@ -61,48 +61,16 @@ package require Tcl 8.6-
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::pipe::class {
#*** !doctools
#[subsection {Namespace punk::pipe::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 ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::pipe {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection {Namespace punk::pipe}]
#[para] Core API functions for punk::pipe
#[para] Core API functions for punk::pipe
#[list_begin definitions]
@ -110,13 +78,13 @@ tcl::namespace::eval punk::pipe {
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1
# #[para]Description of sample1
# #[para] Arguments:
# # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n.
# # [list_end]
# return "ok"
# return "ok"
#}
#https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/
@ -735,16 +703,6 @@ tcl::namespace::eval punk::pipe::lib {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::pipe::system {
#*** !doctools
#[subsection {Namespace punk::pipe::system}]
#[para] Internal functions that are not part of the API
#}
# == === === === === === === === === === === === === === ===

25
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm

@ -3063,6 +3063,11 @@ namespace eval repl {
return $stack
}
}
#autodoc for ensemble, or a punk::args::define doc here
#will not alow discovery of the documentation from within an interp that has
#only alias access to this - as the docs (indeed even the namespace) won't
#exist in the calling interp.
namespace eval ::repl::interphelpers::subshell_ensemble {
namespace export {[a-z]*}
namespace ensemble create
@ -3259,7 +3264,7 @@ namespace eval repl {
debug\
punk::ns\
textblock\
punk::args::tclcore\
punk::args::moduledoc::tclcore\
punk::aliascore\
]
@ -3333,8 +3338,8 @@ namespace eval repl {
#review
code alias ::shellfilter::stack ::shellfilter::stack
#code alias ::punk::lib::set_clone ::punk::lib::set_clone
#code alias ::aliases ::punk::lib::aliases
code alias ::punk::lib::aliases ::punk::lib::aliases
#code alias ::aliases ::punk::ns::aliases
code alias ::punk::ns::aliases ::punk::ns::aliases
namespace eval ::codeinterp {}
code alias ::md5::md5 ::repl::interphelpers::md5
@ -3443,7 +3448,7 @@ namespace eval repl {
interp eval code {
package require punk::lib
package require punk::args
catch {package require punk::args::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical
catch {package require punk::args::moduledoc::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical
package require textblock
}
@ -3614,7 +3619,7 @@ namespace eval repl {
}} [punk::config::configure running]
package require textblock
catch {package require punk::args::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical
catch {package require punk::args::moduledoc::tclcore} ;#while tclcore is highly desirable, and should be installed with punk::args - it's not critical
} errM]} {
puts stderr "========================"
puts stderr "code interp error:"
@ -3632,6 +3637,16 @@ namespace eval repl {
}
}
code alias repl ::repl::interphelpers::repl_ensemble
code eval {
punk::args::define {
@id -id ::subshell
@cmd -name ::subshell\
-summary "Launch in-process subshell"\
-help "Launch a thread-based subshell"
shellname -type string -optional 0 -choices {punk punksafe safe safebase}
}
}
code alias subshell ::repl::interphelpers::subshell_ensemble
code alias quit ::repl::interphelpers::quit
code alias editbuf ::repl::interphelpers::editbuf

1
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm

@ -58,7 +58,6 @@ package require punk::args
package require punk::char
package require punk::ansi
package require punk::lib
catch {package require patternpunk}
package require overtype
package require struct::set

12
src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl

@ -1760,9 +1760,10 @@ if {$::punkboot::command eq "vendorupdate"} {
set vendor_config $sourcefolder/vendormodules$which/include_modules.config ;#todo - change to toml
if {[file exists $vendor_config]} {
set targetroot $sourcefolder/vendormodules$which
set local_modules [list]
source $vendor_config ;#populate $local_modules $git_modules $fossil_modules with project-specific list
if {![llength $local_modules]} {
puts stderr "src/vendormodules$which No local vendor modules configured for updating (config file: $vendor_config)"
puts stderr "\nsrc/vendormodules$which No local vendor modules configured for updating (config file: $vendor_config)"
} else {
if {[catch {
#----------
@ -1775,10 +1776,15 @@ if {$::punkboot::command eq "vendorupdate"} {
set installation_event ""
}
#todo - sync alg with bootsupport_localupdate!
foreach {relpath requested_module} $local_modules {
foreach {localpath requested_module} $local_modules {
set requested_module [string trim $requested_module :]
set module_subpath [string map {:: /} [namespace qualifiers $requested_module]]
set srclocation [file join $projectroot $relpath $module_subpath]
if {[file pathtype $localpath] eq "relative"} {
#This would actually work for absolute paths too as file join c:/test c:/etc ignores first arg and returns c:/etc
set srclocation [file join $projectroot $localpath $module_subpath]
} else {
set srclocation [file join $localpath $module_subpath]
}
#puts stdout "$relpath $module $module_subpath $srclocation"
#todo - check if requested_module has version extension and allow explicit versions instead of just latest

Loading…
Cancel
Save