Browse Source

drag in more bootsupport modules: punk and dependencies

master
Julian Noble 2 months ago
parent
commit
9c56c500c6
  1. 259
      src/bootsupport/modules/argp-0.2.tm
  2. 306
      src/bootsupport/modules/debug-1.0.6.tm
  3. 2714
      src/bootsupport/modules/flagfilter-0.3.tm
  4. 322
      src/bootsupport/modules/funcl-0.1.tm
  5. 26
      src/bootsupport/modules/include_modules.config
  6. 6411
      src/bootsupport/modules/metaface-1.2.5.tm
  7. 1285
      src/bootsupport/modules/pattern-1.2.4.tm
  8. 645
      src/bootsupport/modules/patterncmd-1.2.4.tm
  9. 2590
      src/bootsupport/modules/patternlib-1.2.6.tm
  10. 754
      src/bootsupport/modules/patternpredator2-1.2.4.tm
  11. 7806
      src/bootsupport/modules/punk-0.1.tm
  12. 272
      src/bootsupport/modules/punk/aliascore-0.1.0.tm
  13. 475
      src/bootsupport/modules/punk/config-0.1.tm
  14. 164
      src/bootsupport/modules/punk/mod-0.1.tm
  15. 1373
      src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  16. 259
      src/bootsupport/modules/punk/repl/codethread-0.1.0.tm
  17. 237
      src/bootsupport/modules/punk/unixywindows-0.1.0.tm
  18. 239
      src/bootsupport/modules/punkapp-0.1.tm
  19. 333
      src/bootsupport/modules/punkcheck/cli-0.1.0.tm
  20. 3078
      src/bootsupport/modules/shellfilter-0.1.9.tm
  21. 259
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argp-0.2.tm
  22. 306
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/debug-1.0.6.tm
  23. 2714
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/flagfilter-0.3.tm
  24. 322
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm
  25. 26
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config
  26. 6411
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.5.tm
  27. 1285
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/pattern-1.2.4.tm
  28. 645
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm
  29. 2590
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternlib-1.2.6.tm
  30. 754
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm
  31. 7806
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm
  32. 272
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm
  33. 475
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm
  34. 164
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.tm
  35. 1373
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  36. 259
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm
  37. 237
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/unixywindows-0.1.0.tm
  38. 239
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkapp-0.1.tm
  39. 333
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm
  40. 3078
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm
  41. 259
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/argp-0.2.tm
  42. 306
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/debug-1.0.6.tm
  43. 2714
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/flagfilter-0.3.tm
  44. 322
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/funcl-0.1.tm
  45. 26
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config
  46. 6411
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/metaface-1.2.5.tm
  47. 1285
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/pattern-1.2.4.tm
  48. 645
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm
  49. 2590
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patternlib-1.2.6.tm
  50. 754
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm
  51. 7806
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm
  52. 272
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm
  53. 475
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm
  54. 164
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.tm
  55. 1373
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  56. 259
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm
  57. 237
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/unixywindows-0.1.0.tm
  58. 239
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkapp-0.1.tm
  59. 333
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm
  60. 3078
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm

259
src/bootsupport/modules/argp-0.2.tm

@ -0,0 +1,259 @@
# Tcl parser for optional arguments in function calls and
# commandline arguments
#
# (c) 2001 Bastien Chevreux
# Index of exported commands
# - argp::registerArgs
# - argp::setArgDefaults
# - argp::setArgsNeeded
# - argp::parseArgs
# Internal commands
# - argp::CheckValues
# See end of file for an example on how to use
package provide argp 0.2
namespace eval argp {
variable Optstore
variable Opttypes {
boolean integer double string
}
namespace export {[a-z]*}
}
proc argp::registerArgs { func arglist } {
variable Opttypes
variable Optstore
set parentns [string range [uplevel 1 [list namespace current]] 2 end]
if { $parentns != "" } {
append caller $parentns :: $func
} else {
set caller $func
}
set cmangled [string map {:: _} $caller]
#puts $parentns
#puts $caller
#puts $cmangled
set Optstore(keys,$cmangled) {}
set Optstore(deflist,$cmangled) {}
set Optstore(argneeded,$cmangled) {}
foreach arg $arglist {
foreach {opt type default allowed} $arg {
set optindex [lsearch -glob $Opttypes $type*]
if { $optindex < 0} {
return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]"
}
set type [lindex $Opttypes $optindex]
lappend Optstore(keys,$cmangled) $opt
set Optstore(type,$opt,$cmangled) $type
set Optstore(default,$opt,$cmangled) $default
set Optstore(allowed,$opt,$cmangled) $allowed
lappend Optstore(deflist,$cmangled) $opt $default
}
}
if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} {
return -code error "Error in declaration of optional arguments.\n$res"
}
}
proc argp::setArgDefaults { func arglist } {
variable Optstore
set parentns [string range [uplevel 1 [list namespace current]] 2 end]
if { $parentns != "" } {
append caller $parentns :: $func
} else {
set caller $func
}
set cmangled [string map {:: _} $caller]
if {![info exists Optstore(deflist,$cmangled)]} {
return -code error "Arguments for $caller not registered yet."
}
set Optstore(deflist,$cmangled) {}
foreach {opt default} $arglist {
if {![info exists Optstore(default,$opt,$cmangled)]} {
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)"
}
set Optstore(default,$opt,$cmangled) $default
}
# set the new defaultlist
foreach opt $Optstore(keys,$cmangled) {
lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled)
}
}
proc argp::setArgsNeeded { func arglist } {
variable Optstore
set parentns [string range [uplevel 1 [list namespace current]] 2 end]
if { $parentns != "" } {
append caller $parentns :: $func
} else {
set caller $func
}
set cmangled [string map {:: _} $caller]
#append caller $parentns :: $func
#set cmangled ${parentns}_$func
if {![info exists Optstore(deflist,$cmangled)]} {
return -code error "Arguments for $caller not registered yet."
}
set Optstore(argneeded,$cmangled) {}
foreach opt $arglist {
if {![info exists Optstore(default,$opt,$cmangled)]} {
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)"
}
lappend Optstore(argneeded,$cmangled) $opt
}
}
proc argp::parseArgs { args } {
variable Optstore
if {[llength $args] == 0} {
upvar args a opts o
} else {
upvar args a [lindex $args 0] o
}
if { [ catch { set caller [lindex [info level -1] 0]}]} {
set caller "main program"
set cmangled ""
} else {
set cmangled [string map {:: _} $caller]
}
if {![info exists Optstore(deflist,$cmangled)]} {
return -code error "Arguments for $caller not registered yet."
}
# set the defaults
array set o $Optstore(deflist,$cmangled)
# but unset the needed arguments
foreach key $Optstore(argneeded,$cmangled) {
catch { unset o($key) }
}
foreach {key val} $a {
if {![info exists Optstore(type,$key,$cmangled)]} {
return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)"
}
switch -exact -- $Optstore(type,$key,$cmangled) {
boolean -
integer {
if { $val == "" } {
return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value."
}
if { ![string is $Optstore(type,$key,$cmangled) $val]} {
return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value."
}
}
double {
if { $val == "" } {
return -code error "$caller, $key empty string is not double value."
}
if { ![string is double $val]} {
return -code error "$caller, $key $val is not double value."
}
if { [string is integer $val]} {
set val [expr {$val + .0}]
}
}
default {
}
}
set o($key) $val
}
foreach key $Optstore(argneeded,$cmangled) {
if {![info exists o($key)]} {
return -code error "$caller, needed argument $key was not given."
}
}
if { [catch { CheckValues $caller $cmangled [array get o]} err]} {
return -code error $err
}
return
}
proc argp::CheckValues { caller cmangled checklist } {
variable Optstore
#puts "Checking $checklist"
foreach {key val} $checklist {
if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } {
switch -exact -- $Optstore(type,$key,$cmangled) {
string {
if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} {
return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)"
}
}
double -
integer {
set found 0
foreach range $Optstore(allowed,$key,$cmangled) {
if {[llength $range] == 1} {
if { $val == [lindex $range 0] } {
set found 1
break
}
} elseif {[llength $range] == 2} {
set low [lindex $range 0]
set high [lindex $range 1]
if { ![string is integer $low] \
&& [string compare "-" $low] != 0} {
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not \u00b4-\u00b4: $range"
}
if { ![string is integer $high] \
&& [string compare "+" $high] != 0} {
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not \u00b4+\u00b4: $range"
}
if {[string compare "-" $low] == 0} {
if { [string compare "+" $high] == 0 \
|| $val <= $high } {
set found 1
break
}
}
if { $val >= $low } {
if {[string compare "+" $high] == 0 \
|| $val <= $high } {
set found 1
break
}
}
} else {
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range"
}
}
if { $found == 0 } {
return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)"
}
}
}
}
}
}

306
src/bootsupport/modules/debug-1.0.6.tm

@ -0,0 +1,306 @@
# Debug - a debug narrative logger.
# -- Colin McCormack / originally Wub server utilities
#
# Debugging areas of interest are represented by 'tokens' which have
# independantly settable levels of interest (an integer, higher is more detailed)
#
# Debug narrative is provided as a tcl script whose value is [subst]ed in the
# caller's scope if and only if the current level of interest matches or exceeds
# the Debug call's level of detail. This is useful, as one can place arbitrarily
# complex narrative in code without unnecessarily evaluating it.
#
# TODO: potentially different streams for different areas of interest.
# (currently only stderr is used. there is some complexity in efficient
# cross-threaded streams.)
# # ## ### ##### ######## ############# #####################
## Requisites
package require Tcl 8.5-
namespace eval ::debug {
namespace export -clear \
define on off prefix suffix header trailer \
names 2array level setting parray pdict \
nl tab hexl
namespace ensemble create -subcommands {}
}
# # ## ### ##### ######## ############# #####################
## API & Implementation
proc ::debug::noop {args} {}
proc ::debug::debug {tag message {level 1}} {
variable detail
if {$detail($tag) < $level} {
#puts stderr "$tag @@@ $detail($tag) >= $level"
return
}
variable prefix
variable suffix
variable header
variable trailer
variable fds
if {[info exists fds($tag)]} {
set fd $fds($tag)
} else {
set fd stderr
}
# Assemble the shown text from the user message and the various
# prefixes and suffices (global + per-tag).
set themessage ""
if {[info exists prefix(::)]} { append themessage $prefix(::) }
if {[info exists prefix($tag)]} { append themessage $prefix($tag) }
append themessage $message
if {[info exists suffix($tag)]} { append themessage $suffix($tag) }
if {[info exists suffix(::)]} { append themessage $suffix(::) }
# Resolve variables references and command invokations embedded
# into the message with plain text.
set code [catch {
set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]]
set sheader [uplevel 1 [list ::subst -nobackslashes $header]]
set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]]
} __ eo]
# And dump an internal error if that resolution failed.
if {$code} {
if {[catch {
set caller [info level -1]
}]} { set caller GLOBAL }
if {[string length $caller] >= 1000} {
set caller "[string range $caller 0 200]...[string range $caller end-200 end]"
}
foreach line [split $caller \n] {
puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)"
}
return
}
# From here we have a good message to show. We only shorten it a
# bit if its a bit excessive in size.
if {[string length $smessage] > 4096} {
set head [string range $smessage 0 2048]
set tail [string range $smessage end-2048 end]
set smessage "${head}...(truncated)...$tail"
}
foreach line [split $smessage \n] {
puts $fd "$sheader$tag | $line$strailer"
}
return
}
# names - return names of debug tags
proc ::debug::names {} {
variable detail
return [lsort [array names detail]]
}
proc ::debug::2array {} {
variable detail
set result {}
foreach n [lsort [array names detail]] {
if {[interp alias {} debug.$n] ne "::debug::noop"} {
lappend result $n $detail($n)
} else {
lappend result $n -$detail($n)
}
}
return $result
}
# level - set level and fd for tag
proc ::debug::level {tag {level ""} {fd {}}} {
variable detail
# TODO: Force level >=0.
if {$level ne ""} {
set detail($tag) $level
}
if {![info exists detail($tag)]} {
set detail($tag) 1
}
variable fds
if {$fd ne {}} {
set fds($tag) $fd
}
return $detail($tag)
}
proc ::debug::header {text} { variable header $text }
proc ::debug::trailer {text} { variable trailer $text }
proc ::debug::define {tag} {
if {[interp alias {} debug.$tag] ne {}} return
off $tag
return
}
# Set a prefix/suffix to use for tag.
# The global (tag-independent) prefix/suffix is adressed through tag '::'.
# This works because colon (:) is an illegal character for user-specified tags.
proc ::debug::prefix {tag {theprefix {}}} {
variable prefix
set prefix($tag) $theprefix
if {[interp alias {} debug.$tag] ne {}} return
off $tag
return
}
proc ::debug::suffix {tag {theprefix {}}} {
variable suffix
set suffix($tag) $theprefix
if {[interp alias {} debug.$tag] ne {}} return
off $tag
return
}
# turn on debugging for tag
proc ::debug::on {tag {level ""} {fd {}}} {
variable active
set active($tag) 1
level $tag $level $fd
interp alias {} debug.$tag {} ::debug::debug $tag
return
}
# turn off debugging for tag
proc ::debug::off {tag {level ""} {fd {}}} {
variable active
set active($tag) 1
level $tag $level $fd
interp alias {} debug.$tag {} ::debug::noop
return
}
proc ::debug::setting {args} {
if {[llength $args] == 1} {
set args [lindex $args 0]
}
set fd stderr
if {[llength $args] % 2} {
set fd [lindex $args end]
set args [lrange $args 0 end-1]
}
foreach {tag level} $args {
if {$level > 0} {
level $tag $level $fd
interp alias {} debug.$tag {} ::debug::debug $tag
} else {
level $tag [expr {-$level}] $fd
interp alias {} debug.$tag {} ::debug::noop
}
}
return
}
# # ## ### ##### ######## ############# #####################
## Convenience commands.
# Format arrays and dicts as multi-line message.
# Insert newlines and tabs.
proc ::debug::nl {} { return \n }
proc ::debug::tab {} { return \t }
proc ::debug::parray {a {pattern *}} {
upvar 1 $a array
if {![array exists array]} {
error "\"$a\" isn't an array"
}
pdict [array get array] $pattern
}
proc ::debug::pdict {dict {pattern *}} {
set maxl 0
set names [lsort -dict [dict keys $dict $pattern]]
foreach name $names {
if {[string length $name] > $maxl} {
set maxl [string length $name]
}
}
set maxl [expr {$maxl + 2}]
set lines {}
foreach name $names {
set nameString [format (%s) $name]
lappend lines [format "%-*s = %s" \
$maxl $nameString \
[dict get $dict $name]]
}
return [join $lines \n]
}
proc ::debug::hexl {data {prefix {}}} {
set r {}
# Convert the data to hex and to characters.
binary scan $data H*@0a* hexa asciia
# Replace non-printing characters in the data with dots.
regsub -all -- {[^[:graph:] ]} $asciia {.} asciia
# Pad with spaces to a full multiple of 32/16.
set n [expr {[string length $hexa] % 32}]
if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] }
#puts "pad H [expr {32-$n}]"
set n [expr {[string length $asciia] % 32}]
if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] }
#puts "pad A [expr {32-$n}]"
# Reassemble formatted, in groups of 16 bytes/characters.
# The hex part is handled in groups of 32 nibbles.
set addr 0
while {[string length $hexa]} {
# Get front group of 16 bytes each.
set hex [string range $hexa 0 31]
set ascii [string range $asciia 0 15]
# Prep for next iteration
set hexa [string range $hexa 32 end]
set asciia [string range $asciia 16 end]
# Convert the hex to pairs of hex digits
regsub -all -- {..} $hex {& } hex
# Add the hex and latin-1 data to the result buffer
append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n
incr addr 16
}
# And done
return $r
}
# # ## ### ##### ######## ############# #####################
namespace eval debug {
variable detail ; # map: TAG -> level of interest
variable prefix ; # map: TAG -> message prefix to use
variable suffix ; # map: TAG -> message suffix to use
variable fds ; # map: TAG -> handle of open channel to log to.
variable header {} ; # per-line heading, subst'ed
variable trailer {} ; # per-line ending, subst'ed
# Notes:
# - The tag '::' is reserved. "prefix" and "suffix" use it to store
# the global message prefix / suffix.
# - prefix and suffix are applied per message.
# - header and trailer are per line. And should not generate multiple lines!
}
# # ## ### ##### ######## ############# #####################
## Ready
package provide debug 1.0.6
return

2714
src/bootsupport/modules/flagfilter-0.3.tm

File diff suppressed because it is too large Load Diff

322
src/bootsupport/modules/funcl-0.1.tm

@ -0,0 +1,322 @@
package provide funcl [namespace eval funcl {
variable version
set version 0.1
}]
#funcl = function list (nested call structure)
#
#a basic functional composition o combinator
#o(f,g)(x) == f(g(x))
namespace eval funcl {
#from punk
proc arg_is_script_shaped {arg} {
if {[string first " " $arg] >= 0} {
return 1
} elseif {[string first \n $arg] >= 0} {
return 1
} elseif {[string first ";" $arg] >= 0} {
return 1
} elseif {[string first \t $arg] >= 0} {
return 1
} else {
return 0
}
}
proc o args {
set closing [string repeat {]} [expr [llength $args]-1]]
set body "[join $args { [}] \$data $closing"
return $body
}
proc o_ args {
set body ""
set tails [lrepeat [llength $args] ""]
puts stdout "tails: $tails"
set end [lindex $args end]
if {[llength $end] == 1 && [arg_is_script_shaped $end]} {
set endfunc [string map "<end> $end" {uplevel 1 [list if 1 <end> ]}]
} else {
set endfunc $end
}
if {[llength $args] == 1} {
return $endfunc
}
set wrap { [}
append wrap $endfunc
append wrap { ]}
set i 0
foreach cmdlist [lrange $args 0 end-1] {
set is_script 0
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} {
set is_script 1
set script [lindex $cmdlist 0]
}
set t ""
if {$i > 0} {
append body { [}
}
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
if {$i == [expr {[llength $args] -2}]} {
#append body " \$data"
append body " $wrap"
}
if {$i > 0} {
set t {]}
}
} else {
append body [lrange $cmdlist 0 $posn-1]
if {$i == [expr {[llength $args] -2}]} {
#append body " \$data"
append body " $wrap"
}
set t [lrange $cmdlist $posn+1 end]
if {$i > 0} {
append t { ]}
}
}
lset tails $i $t
incr i
}
append body [join [lreverse $tails] " "]
puts stdout "tails: $tails"
return $body
}
#review - consider _call -- if count > 1 then they must all be callable cmdlists(?)
# what does it mean to have additional _fn wrapper with no other elements? (no actual function)
#e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}}
# what type indicates running subtrees in parallel vs sequentially?
# any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc.
#
#
# accept or return a funcl (or funcltree if multiple funcls in one commandlist)
# also accept/return a call - return empty list if passed a call
proc next_funcl {funcl_or_tree} {
if {[lindex $funcl_or_tree 0] eq "_call"} {
return [list]
}
if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} {
set funcl $funcl_or_tree
} else {
error "funcltree not implemented"
}
set count [lindex $funcl 1]
if {$count == 0} {
#null funcl.. what is it? metadata/placeholder?
return $funcl
}
set indices [lrange $funcl 2 [expr {1 + $count}]]
set i 0
foreach idx $indices {
if {$i > 0} {
#todo - return a funcltree
error "multi funcl not implemented"
}
set next [lindex $funcl $idx]
incr i
}
return $next
}
#convert a funcl to a tcl script
proc funcl_script {funcl} {
if {![llength $funcl]} {
return ""
}
set body ""
set tails [list]
set type [lindex $funcl 0]
if {$type ni [list "_fn" "_call"]} {
#todo - handle funcltree
error "type $type not implemented"
}
#only count of 1 with index 3 supported(?)
if {$type eq "_call"} {
#leaf
set cmdlist [lindex $funcl 3]
return $cmdlist
}
#we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times.
#by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?)
# we would still need to maintain state to stitch it back together once returned from a subtree..
# ie multiple tail parts
set count [lindex $funcl 1]
if {$count == 1} {
set idx [lindex $funcl 2]
if {$idx == 3} {
set cmdlist_pre [list]
} else {
set cmdlist_pre [lrange $funcl 3 $idx-1]
}
append body $cmdlist_pre
set t [lrange $funcl $idx+1 end]
lappend tails $t
} else {
#??
error "funcl_script branching not yet supported"
}
set get_next 1
set i 1
while {$get_next} {
set funcl [next_funcl $funcl]
if {![llength $funcl]} {
set get_next 0
}
lassign $funcl type count idx ;#todo support count > 1
if {$type eq "_call"} {
set get_next 0
}
set t ""
if {$type eq "_call"} {
append body { [}
append body [lindex $funcl $idx]
append body { ]}
} else {
append body { [}
if {$idx == 3} {
set cmdlist_pre [list]
} else {
set cmdlist_pre [lrange $funcl 3 $idx-1]
}
append body $cmdlist_pre
set t [lrange $funcl $idx+1 end]
lappend tails $t
lappend tails { ]}
}
incr i
}
append body [join [lreverse $tails] " "]
#puts stdout "tails: $tails"
return $body
}
interp alias "" o_of "" funcl::o_of_n 1
#o_of_n
#tcl list rep o combinator
#
# can take lists of ordinary commandlists, scripts and funcls
# _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg)
# _fn 0 indicates next item is an unwrapped commandlist (terminal command)
#
#o_of is equivalent to o_of_n 1 (1 argument o combinator)
#last n args are passed to the prior function
#e.g for n=1 f a b = f(a(b))
#e.g for n=2, e f a b = e(f(a b))
proc o_of_n {n args} {
puts stdout "o_of_n '$args'"
if {$n != 1} {
error "o_of_n only implemented for 1 sub-funcl"
}
set comp [list] ;#composition list
set end [lindex $args end]
if {[lindex $end 0] in {_fn _call}]} {
#is_funcl
set endfunc [lindex $args end]
} else {
if {[llength $end] == 1 && [arg_is_script_shaped $end]} {
#set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}]
set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]]
} else {
set endfunc [list _call 1 3 [list {*}$end]]
}
}
if {[llength $args] == 1} {
return $endfunc
}
set comp $endfunc
set revlist [lreverse [lrange $args 0 end-1]]
foreach cmdlist $revlist {
puts stderr "o_of_n >>-- $cmdlist"
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} {
set is_script 1
set script [lindex $cmdlist 0]
set arglist [list data]
set comp [list _fn 1 6 call_script $script $arglist $comp]
} else {
set posn1 [expr {[llength $cmdlist] + 2 + $n}]
set comp [list _fn $n $posn1 {*}$cmdlist $comp]
}
}
return $comp
}
proc call_script {script argnames args} {
uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]]
}
proc funcl_script_test {scr} {
do_funcl_script_test $scr
}
proc do_funcl_script_test {scr} {
#set j "in do_funcl_script_test"
#set data "xxx"
#puts '$scr'
if 1 $scr
}
#standard o_ with no script-handling
proc o_plain args {
set body ""
set i 0
set tails [lrepeat [llength $args] ""]
#puts stdout "tails: $tails"
foreach cmdlist $args {
set t ""
if {$i > 0} {
append body { [}
}
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
if {$i == [expr {[llength $args] -1}]} {
append body " \$data"
}
if {$i > 0} {
set t {]}
}
} else {
append body [lrange $cmdlist 0 $posn-1]
if {$i == [expr {[llength $args] -1}]} {
append body " \$data"
}
set t [lrange $cmdlist $posn+1 end]
if {$i > 0} {
append t { ]}
}
}
lset tails $i $t
incr i
}
append body [join [lreverse $tails] " "]
#puts stdout "tails: $tails"
return $body
}
#timings suggest no faster to split out the first item from the cmdlist loop
}

26
src/bootsupport/modules/include_modules.config

@ -2,18 +2,29 @@
#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project #bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project
#They must be already built, so generally shouldn't come directly from src/modules. #They must be already built, so generally shouldn't come directly from src/modules.
#we want showdict - but it needs punk pipeline notation.
#this requires pulling in punk - which brings in lots of other stuff
#The original idea was that bootsupport could be a subset - but in practice we seem to need pretty much everything?
#we still get the advantage that the bootsupport modules can be updated independently (less frequently - after testing)
#each entry - base module #each entry - base module
set bootsupport_modules [list\ set bootsupport_modules [list\
src/vendormodules commandstack\ src/vendormodules commandstack\
src/vendormodules cksum\ src/vendormodules cksum\
src/vendormodules debug\
src/vendormodules dictutils\ src/vendormodules dictutils\
src/vendormodules fauxlink\ src/vendormodules fauxlink\
src/vendormodules fileutil\ src/vendormodules fileutil\
src/vendormodules http\ src/vendormodules http\
src/vendormodules md5\ src/vendormodules md5\
src/vendormodules metaface\
src/vendormodules modpod\ src/vendormodules modpod\
src/vendormodules oolib\ src/vendormodules oolib\
src/vendormodules overtype\ src/vendormodules overtype\
src/vendormodules pattern\
src/vendormodules patterncmd\
src/vendormodules patternlib\
src/vendormodules patternpredator2\
src/vendormodules sha1\ src/vendormodules sha1\
src/vendormodules tomlish\ src/vendormodules tomlish\
src/vendormodules test::tomlish\ src/vendormodules test::tomlish\
@ -25,8 +36,15 @@ set bootsupport_modules [list\
src/vendormodules textutil::trim\ src/vendormodules textutil::trim\
src/vendormodules textutil::wcswidth\ src/vendormodules textutil::wcswidth\
src/vendormodules uuid\ src/vendormodules uuid\
modules punkcheck\ modules argp\
modules flagfilter\
modules funcl\
modules natsort\ modules natsort\
modules punk\
modules punkapp\
modules punkcheck\
modules punkcheck::cli\
modules punk::aliascore\
modules punk::ansi\ modules punk::ansi\
modules punk::assertion\ modules punk::assertion\
modules punk::args\ modules punk::args\
@ -35,6 +53,7 @@ set bootsupport_modules [list\
modules punk::cap::handlers::scriptlibs\ modules punk::cap::handlers::scriptlibs\
modules punk::cap::handlers::templates\ modules punk::cap::handlers::templates\
modules punk::char\ modules punk::char\
modules punk::config\
modules punk::console\ modules punk::console\
modules punk::du\ modules punk::du\
modules punk::encmime\ modules punk::encmime\
@ -46,6 +65,7 @@ set bootsupport_modules [list\
modules punk::mix::cli\ modules punk::mix::cli\
modules punk::mix::util\ modules punk::mix::util\
modules punk::mix::templates\ modules punk::mix::templates\
modules punk::repl::codethread\
modules punk::mix::commandset::buildsuite\ modules punk::mix::commandset::buildsuite\
modules punk::mix::commandset::debug\ modules punk::mix::commandset::debug\
modules punk::mix::commandset::doc\ modules punk::mix::commandset::doc\
@ -55,14 +75,18 @@ set bootsupport_modules [list\
modules punk::mix::commandset::project\ modules punk::mix::commandset::project\
modules punk::mix::commandset::repo\ modules punk::mix::commandset::repo\
modules punk::mix::commandset::scriptwrap\ modules punk::mix::commandset::scriptwrap\
modules punk::mod\
modules punk::nav::fs\
modules punk::ns\ modules punk::ns\
modules punk::overlay\ modules punk::overlay\
modules punk::path\ modules punk::path\
modules punk::packagepreference\ modules punk::packagepreference\
modules punk::repo\ modules punk::repo\
modules punk::tdl\ modules punk::tdl\
modules punk::unixywindows\
modules punk::zip\ modules punk::zip\
modules punk::winpath\ modules punk::winpath\
modules shellfilter\
modules textblock\ modules textblock\
modules natsort\ modules natsort\
modules oolib\ modules oolib\

6411
src/bootsupport/modules/metaface-1.2.5.tm

File diff suppressed because it is too large Load Diff

1285
src/bootsupport/modules/pattern-1.2.4.tm

File diff suppressed because it is too large Load Diff

645
src/bootsupport/modules/patterncmd-1.2.4.tm

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

2590
src/bootsupport/modules/patternlib-1.2.6.tm

File diff suppressed because it is too large Load Diff

754
src/bootsupport/modules/patternpredator2-1.2.4.tm

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

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

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,272 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application punk::aliascore 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::aliascore 0 0.1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require punk::aliascore]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::aliascore
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::aliascore
#[list_begin itemized]
package require Tcl 8.6-
#*** !doctools
#[item] [package {Tcl 8.6}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::aliascore::class {
# #*** !doctools
# #[subsection {Namespace punk::aliascore::class}]
# #[para] class definitions
# if {[info commands [namespace current]::interface_sample1] eq ""} {
# #*** !doctools
# #[list_begin enumerated]
#
# # oo::class create interface_sample1 {
# # #*** !doctools
# # #[enum] CLASS [class interface_sample1]
# # #[list_begin definitions]
#
# # method test {arg1} {
# # #*** !doctools
# # #[call class::interface_sample1 [method test] [arg arg1]]
# # #[para] test method
# # puts "test: $arg1"
# # }
#
# # #*** !doctools
# # #[list_end] [comment {-- end definitions interface_sample1}]
# # }
#
# #*** !doctools
# #[list_end] [comment {--- end class enumeration ---}]
# }
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::aliascore {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
variable aliases
#use absolute ns ie must be prefixed with ::
#single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased
#functions must be in export list of their source namespace
set aliases [tcl::dict::create\
tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\
linelist ::punk::lib::linelist\
linesort ::punk::lib::linesort\
pdict ::punk::lib::pdict\
plist {::punk::lib::pdict -roottype list}\
showlist {::punk::lib::showdict -roottype list}\
showdict ::punk::lib::showdict\
ansistrip ::punk::ansi::ansistrip\
stripansi ::punk::ansi::ansistrip\
ansiwrap ::punk::ansi::ansiwrap\
colour ::punk::console::colour\
ansi ::punk::console::ansi\
color ::punk::console::colour\
a+ ::punk::console::code_a+\
A+ {::punk::console::code_a+ forcecolour}\
a ::punk::console::code_a\
A {::punk::console::code_a forcecolour}\
a? ::punk::console::code_a?\
A? {::punk::console::code_a? forcecolor}\
smcup ::punk::console::enable_alt_screen\
rmcup ::punk::console::disable_alt_screen\
]
#*** !doctools
#[subsection {Namespace punk::aliascore}]
#[para] Core API functions for punk::aliascore
#[list_begin definitions]
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[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"
#}
#todo - options as to whether we should raise an error if collisions found, undo aliases etc?
proc init {args} {
set defaults {-force 0}
set opts [dict merge $defaults $args]
set opt_force [dict get $opts -force]
variable aliases
if {!$opt_force} {
set existing [list]
set conflicts [list]
foreach {a cmd} $aliases {
if {[tcl::info::commands ::$a] ne ""} {
lappend existing $a
if {[llength $cmd] > 1} {
#use alias mechanism
set existing_target [interp alias "" $a]
} else {
#using namespace import
#check origin
set existing_target [tcl::namespace::origin $cmd]
}
if {$existing_target ne $cmd} {
#command exists in global ns but doesn't match our defined aliases/imports
lappend conflicts $a
}
}
}
if {[llength $conflicts]} {
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts"
}
}
set tempns ::temp_[info cmdcount] ;#temp ns for renames
dict for {a cmd} $aliases {
#puts "aliascore $a -> $cmd"
if {[llength $cmd] > 1} {
interp alias {} $a {} {*}$cmd
} else {
if {[tcl::info::commands $cmd] ne ""} {
#todo - ensure exported? noclobber?
if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} {
#puts stderr "importing $cmd"
tcl::namespace::eval :: [list namespace import $cmd]
} else {
#target command name differs from exported name
#e.g stripansi -> punk::ansi::ansistrip
#import and rename
#puts stderr "importing $cmd (with rename to ::$a)"
tcl::namespace::eval $tempns [list namespace import $cmd]
catch {rename ${tempns}::[namespace tail $cmd] ::$a}
}
} else {
interp alias {} $a {} {*}$cmd
}
}
}
#tcl::namespace::delete $tempns
return [dict keys $aliases]
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::aliascore ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#interp alias {} list_as_lines {} punk::lib::list_as_lines
#interp alias {} lines_as_list {} punk::lib::lines_as_list
#interp alias {} ansistrip {} punk::ansi::ansistrip ;#review
#interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features
#interp alias {} linesort {} punk::lib::linesort
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::aliascore::lib {
namespace export {[a-z]*} ;# Convention: export all lowercase
namespace path [namespace parent]
#*** !doctools
#[subsection {Namespace punk::aliascore::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::aliascore::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
namespace eval punk::aliascore::system {
#*** !doctools
#[subsection {Namespace punk::aliascore::system}]
#[para] Internal functions that are not part of the API
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::aliascore [namespace eval punk::aliascore {
variable pkg punk::aliascore
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

475
src/bootsupport/modules/punk/config-0.1.tm

@ -0,0 +1,475 @@
tcl::namespace::eval punk::config {
variable loaded
variable startup ;#include env overrides
variable running
variable punk_env_vars
variable other_env_vars
variable vars
namespace export {[a-z]*}
#todo - XDG_DATA_HOME etc
#https://specifications.freedesktop.org/basedir-spec/latest/
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/
proc init {} {
variable defaults
variable startup
variable running
variable punk_env_vars
variable punk_env_vars_config
variable other_env_vars
variable other_env_vars_config
set exename ""
catch {
#catch for safe interps
#safe base will return empty string, ordinary safe interp will raise error
set exename [tcl::info::nameofexecutable]
}
if {$exename ne ""} {
set exefolder [file dirname $exename]
#default file logs to logs folder at same level as exe if writable, or empty string
set log_folder [file normalize $exefolder/../logs]
#tcl::dict::set startup scriptlib $exefolder/scriptlib
#tcl::dict::set startup apps $exefolder/../../punkapps
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc
set default_scriptlib $exefolder/scriptlib
set default_apps $exefolder/../../punkapps
if {[file isdirectory $log_folder] && [file writable $log_folder]} {
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt
set default_logfile_stdout $log_folder/repl-exec-stdout.txt
set default_logfile_stderr $log_folder/repl-exec-stderr.txt
} else {
set default_logfile_stdout ""
set default_logfile_stderr ""
}
} else {
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island
#review - todo?
#tcl::dict::set startup scriptlib ""
#tcl::dict::set startup apps ""
set default_scriptlib ""
set default_apps ""
set default_logfile_stdout ""
set default_logfile_stderr ""
}
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run
#optional channel transforms on stdout/stderr.
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands
#If no distinction necessary - should use default_color_<chan>
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation.
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc)
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful.
#set default_color_stderr "red bold"
#set default_color_stderr "web-lightsalmon"
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive
set default_color_stderr_repl "" ;#during repl call only
set homedir ""
if {[catch {
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp
set homedir [file home]
} errM]} {
#tcl 8.6 doesn't have file home.. try again
if {[info exists ::env(HOME)]} {
set homedir $::env(HOME)
}
}
# per user xdg vars
# ---
set default_xdg_config_home "" ;#config data - portable
set default_xdg_data_home "" ;#data the user likely to want to be portable
set default_xdg_cache_home "" ;#local cache
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home
# ---
set default_xdg_data_dirs "" ;#non-user specific
#xdg_config_dirs ?
#xdg_runtime_dir ?
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent)
#(safe interp generally won't have access to ::env either)
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent.
if {$homedir ne ""} {
if {"windows" eq $::tcl_platform(platform)} {
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them.
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment)
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do.
if {[info exists ::env(APPDATA)]} {
set default_xdg_config_home $::env(APPDATA)
set default_xdg_data_home $::env(APPDATA)
}
#The xdg_cache_home should be kept local
if {[info exists ::env(LOCALAPPDATA)]} {
set default_xdg_cache_home $::env(LOCALAPPDATA)
set default_xdg_state_home $::env(LOCALAPPDATA)
}
if {[info exists ::env(PROGRAMDATA)]} {
#- equiv env(ALLUSERSPROFILE) ?
set default_xdg_data_dirs $::env(PROGRAMDATA)
}
} else {
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html
set default_xdg_config_home [file join $homedir .config]
set default_xdg_data_home [file join $homedir .local share]
set default_xdg_cache_home [file join $homedir .cache]
set default_xdg_state_home [file join $homedir .local state]
set default_xdg_data_dirs /usr/local/share
}
}
set defaults [dict create\
apps $default_apps\
config ""\
configset ".punkshell"\
scriptlib $default_scriptlib\
color_stdout $default_color_stdout\
color_stdout_repl $default_color_stdout_repl\
color_stderr $default_color_stderr\
color_stderr_repl $default_color_stderr_repl\
logfile_stdout $default_logfile_stdout\
logfile_stderr $default_logfile_stderr\
logfile_active 0\
syslog_stdout "127.0.0.1:514"\
syslog_stderr "127.0.0.1:514"\
syslog_active 0\
auto_exec_mechanism exec\
auto_noexec 0\
xdg_config_home $default_xdg_config_home\
xdg_data_home $default_xdg_data_home\
xdg_cache_home $default_xdg_cache_home\
xdg_state_home $default_xdg_state_home\
xdg_data_dirs $default_xdg_data_dirs\
theme_posh_override ""\
posh_theme ""\
posh_themes_path ""\
]
set startup $defaults
#load values from saved config file - $xdg_config_home/punk/punk.config ?
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines.
#that's possibly ok for the PUNK_ vars
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config?
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence?
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden
#- requiring user to manually unset any unwanted env vars when launching?
#we are likely to want the saved configs for subshells/decks to override them however.
#todo - load/save config file
#todo - define which configvars are settable in env
#list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean)
set punk_env_vars_config [dict create \
PUNK_APPS {type pathlist}\
PUNK_CONFIG {type string}\
PUNK_CONFIGSET {type string}\
PUNK_SCRIPTLIB {type string}\
PUNK_AUTO_EXEC_MECHANISM {type string}\
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\
PUNK_LOGFILE_STDOUT {type string}\
PUNK_LOGFILE_STDERR {type string}\
PUNK_LOGFILE_ACTIVE {type string}\
PUNK_SYSLOG_STDOUT {type string}\
PUNK_SYSLOG_STDERR {type string}\
PUNK_SYSLOG_ACTIVE {type string}\
PUNK_THEME_POSH_OVERRIDE {type string}\
]
set punk_env_vars [dict keys $punk_env_vars_config]
#override with env vars if set
foreach {evar varinfo} $punk_env_vars_config {
if {[info exists ::env($evar)]} {
set vartype [dict get $varinfo type]
set f [set ::env($evar)]
if {$f ne "default"} {
#e.g PUNK_SCRIPTLIB -> scriptlib
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]]
if {$vartype eq "pathlist"} {
#colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system
#Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief.
#For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately.
#some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched.
#An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting
# - but some programs have been known to split this value on colon anyway, which breaks things on windows.
set paths [split $f $::tcl_platform(pathSeparator)]
set final [list]
#eliminate empty values (leading or trailing or extraneous separators)
foreach p $paths {
if {[tcl::string::trim $p] ne ""} {
lappend final $p
}
}
tcl::dict::set startup $varname $final
} else {
tcl::dict::set startup $varname $f
}
}
}
}
# https://no-color.org
#if {[info exists ::env(NO_COLOR)]} {
# if {$::env(NO_COLOR) ne ""} {
# set colour_disabled 1
# }
#}
set other_env_vars_config [dict create\
NO_COLOR {type string}\
XDG_CONFIG_HOME {type string}\
XDG_DATA_HOME {type string}\
XDG_CACHE_HOME {type string}\
XDG_STATE_HOME {type string}\
XDG_DATA_DIRS {type pathlist}\
POSH_THEME {type string}\
POSH_THEMES_PATH {type string}\
TCLLIBPATH {type string}\
]
lassign [split [info tclversion] .] tclmajorv tclminorv
#don't rely on lseq or punk::lib for now..
set relevant_minors [list]
for {set i 0} {$i <= $tclminorv} {incr i} {
lappend relevant_minors $i
}
foreach minor $relevant_minors {
set vname TCL${tclmajorv}_${minor}_TM_PATH
if {$minor eq $tclminorv || [info exists ::env($vname)]} {
dict set other_env_vars_config $vname {type string}
}
}
set other_env_vars [dict keys $other_env_vars_config]
foreach {evar varinfo} $other_env_vars_config {
if {[info exists ::env($evar)]} {
set vartype [dict get $varinfo type]
set f [set ::env($evar)]
if {$f ne "default"} {
set varname [tcl::string::tolower $evar]
if {$vartype eq "pathlist"} {
set paths [split $f $::tcl_platform(pathSeparator)]
set final [list]
#eliminate empty values (leading or trailing or extraneous separators)
foreach p $paths {
if {[tcl::string::trim $p] ne ""} {
lappend final $p
}
}
tcl::dict::set startup $varname $final
} else {
tcl::dict::set startup $varname $f
}
}
}
}
#unset -nocomplain vars
#todo
set running [tcl::dict::create]
set running [tcl::dict::merge $running $startup]
}
init
#todo
proc Apply {config} {
puts stderr "punk::config::Apply partially implemented"
set configname [string map {-config ""} $config]
if {$configname in {startup running}} {
upvar ::punk::config::$configname applyconfig
if {[dict exists $applyconfig auto_noexec]} {
set auto [dict get $applyconfig auto_noexec]
if {![string is boolean -strict $auto]} {
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean"
}
if {$auto} {
set ::auto_noexec 1
} else {
#puts "auto_noexec false"
unset -nocomplain ::auto_noexec
}
}
} else {
error "no config named '$config' found"
}
return "apply done"
}
Apply startup
#todo - consider how to divide up settings, categories, 'devices', decks etc
proc get_running_global {varname} {
variable running
if {[dict exists $running $varname]} {
return [dict get $running $varname]
}
error "No such global configuration item '$varname' found in running config"
}
proc get_startup_global {varname} {
variable startup
if {[dict exists $startup $varname]} {
return [dict get $startup $varname]
}
error "No such global configuration item '$varname' found in startup config"
}
proc get {whichconfig {globfor *}} {
variable startup
variable running
switch -- $whichconfig {
config - startup - startup-config - startup-configuration {
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs
set configdata $startup
}
running - running-config - running-configuration {
set configdata $running
}
default {
error "Unknown config name '$whichconfig' - try startup or running"
}
}
if {$globfor eq "*"} {
return $configdata
} else {
set keys [dict keys $configdata [string tolower $globfor]]
set filtered [dict create]
foreach k $keys {
dict set filtered $k [dict get $configdata $k]
}
return $filtered
}
}
proc configure {args} {
set argd [punk::args::get_dict {
whichconfig -type string -choices {startup running}
} $args]
}
proc show {whichconfig {globfor *}} {
#todo - tables for console
set configdata [punk::config::get $whichconfig $globfor]
return [punk::lib::showdict $configdata]
}
#e.g
# copy running-config startup-config
# copy startup-config test-config.cfg
# copy backup-config.cfg running-config
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite
#This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration
proc copy {args} {
set argd [punk::args::get_dict {
*proc -name punk::config::copy -help "Copy a partial or full configuration from one config to another
If a target config has additional settings, then the source config can be considered to be partial with regards to the target.
"
-type -default "" -choices {replace merge} -help "Defaults to merge when target is running-config
Defaults to replace when source is running-config"
*values -min 2 -max 2
fromconfig -help "running or startup or file name (not fully implemented)"
toconfig -help "running or startup or file name (not fully implemented)"
} $args]
set fromconfig [dict get $argd values fromconfig]
set toconfig [dict get $argd values toconfig]
set fromconfig [string map {-config ""} $fromconfig]
set toconfig [string map {-config ""} $toconfig]
set copytype [dict get $argd opts -type]
#todo - warn & prompt if doing merge copy to startup
switch -exact -- $fromconfig-$toconfig {
running-startup {
if {$copytype eq ""} {
set copytype replace ;#full configuration
}
if {$copytype eq "replace"} {
error "punk::config::copy error. full configuration copy from running to startup config not yet supported"
} else {
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported"
}
}
startup-running {
#default type merge - even though it's not always what is desired
if {$copytype eq ""} {
set copytype merge ;#load in a partial configuration
}
#warn/prompt either way
if {$copytype eq "replace"} {
#some routers require use of a separate command for this branch.
#presumably to ensure the user doesn't accidentally load partials onto a running system
#
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported"
} else {
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported"
}
}
default {
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported"
}
}
}
}
#todo - move to cli?
::tcl::namespace::eval punk::config {
#todo - something better - 'previous' rather than reverting to startup
proc channelcolors {{onoff {}}} {
variable running
variable startup
if {![string length $onoff]} {
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]]
} else {
if {![string is boolean $onoff]} {
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no"
}
if {$onoff} {
dict set running color_stdout [dict get $startup color_stdout]
dict set running color_stderr [dict get $startup color_stderr]
} else {
dict set running color_stdout ""
dict set running color_stderr ""
}
}
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]]
}
}
package provide punk::config [tcl::namespace::eval punk::config {
variable version
set version 0.1
}]

164
src/bootsupport/modules/punk/mod-0.1.tm

@ -0,0 +1,164 @@
#punkapps app manager
# deck cli
namespace eval punk::mod::cli {
namespace export help list run
namespace ensemble create
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown
if 0 {
proc _unknown {ns args} {
puts stderr "punk::mod::cli::_unknown '$ns' '$args'"
puts stderr "punk::mod::cli::help $args"
puts stderr "arglen:[llength $args]"
punk::mod::cli::help {*}$args
}
}
#cli must have _init method - usually used to load commandsets lazily
#
variable initialised 0
proc _init {args} {
variable initialised
if {$initialised} {
return
}
#...
set initialised 1
}
proc help {args} {
set basehelp [punk::mix::base help {*}$args]
#namespace export
return $basehelp
}
proc getraw {appname} {
upvar ::punk::config::running running_config
set app_folders [dict get $running_config apps]
#todo search each app folder
set bases [::list]
set versions [::list]
set mains [::list]
set appinfo [::list bases {} mains {} versions {}]
foreach containerfolder $app_folders {
lappend bases $containerfolder
if {[file exists $containerfolder]} {
if {[file exists $containerfolder/$appname/main.tcl]} {
#exact match - only return info for the exact one specified
set namematches $appname
set parts [split $appname -]
} else {
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*]
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort?
}
foreach nm $namematches {
set mainfile $containerfolder/$nm/main.tcl
set parts [split $nm -]
if {[llength $parts] == 1} {
set ver ""
} else {
set ver [lindex $parts end]
}
if {$ver ni $versions} {
lappend versions $ver
lappend mains $ver $mainfile
} else {
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)"
}
}
} else {
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config"
}
}
dict set appinfo versions $versions
#todo - natsort!
set sorted_versions [lsort $versions]
set latest [lindex $sorted_versions 0]
if {$latest eq "" && [llength $sorted_versions] > 1} {
set latest [lindex $sorted_versions 1
}
dict set appinfo latest $latest
dict set appinfo bases $bases
dict set appinfo mains $mains
return $appinfo
}
proc list {{glob *}} {
upvar ::punk::config::running running_config
set apps_folder [dict get $running_config apps]
if {[file exists $apps_folder]} {
if {[file exists $apps_folder/$glob]} {
#tailcall source $apps_folder/$glob/main.tcl
return $glob
}
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob]
if {[llength $apps] == 0} {
if {[string first * $glob] <0 && [string first ? $glob] <0} {
#no glob chars supplied - only launch if exact match for name part
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*]
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort?
if {[llength $namematches] > 0} {
set latest [lindex $namematches end]
lassign $latest nm ver
#tailcall source $apps_folder/$latest/main.tcl
}
}
}
return $apps
}
}
#todo - way to launch as separate process
# solo-opts only before appname - args following appname are passed to the app
proc run {args} {
set nameposn [lsearch -not $args -*]
if {$nameposn < 0} {
error "punkapp::run unable to determine application name"
}
set appname [lindex $args $nameposn]
set controlargs [lrange $args 0 $nameposn-1]
set appargs [lrange $args $nameposn+1 end]
set appinfo [punk::mod::cli::getraw $appname]
if {[llength [dict get $appinfo versions]]} {
set ver [dict get $appinfo latest]
puts stdout "info: $appinfo"
set ::argc [llength $appargs]
set ::argv $appargs
source [dict get $appinfo mains $ver]
if {"-hideconsole" in $controlargs} {
puts stderr "attempting console hide"
#todo - something better - a callback when window mapped?
after 500 {::punkapp::hide_console}
}
return $appinfo
} else {
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]"
}
}
}
namespace eval punk::mod::cli {
proc _cli {args} {
#don't use tailcall - base uses info level to determine caller
::punk::mix::base::_cli {*}$args
}
variable default_command help
package require punk::mix::base
package require punk::overlay
punk::overlay::custom_from_base [namespace current] ::punk::mix::base
}
package provide punk::mod [namespace eval punk::mod {
variable version
set version 0.1
}]

1373
src/bootsupport/modules/punk/nav/fs-0.1.0.tm

File diff suppressed because it is too large Load Diff

259
src/bootsupport/modules/punk/repl/codethread-0.1.0.tm

@ -0,0 +1,259 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application punk::repl::codethread 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require punk::repl::codethread]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::repl::codethread
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::repl::codethread
#[list_begin itemized]
package require Tcl 8.6-
package require punk::config
#*** !doctools
#[item] [package {Tcl 8.6}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::repl::codethread::class {
#*** !doctools
#[subsection {Namespace punk::repl::codethread::class}]
#[para] class definitions
#if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::repl::codethread {
tcl::namespace::export *
variable replthread
variable replthread_cond
variable running 0
variable output_stdout ""
variable output_stderr ""
#variable xyz
#*** !doctools
#[subsection {Namespace punk::repl::codethread}]
#[para] Core API functions for punk::repl::codethread
#[list_begin definitions]
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[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"
#}
proc is_running {} {
variable running
return $running
}
proc runscript {script} {
#puts stderr "->runscript"
variable replthread_cond
variable output_stdout ""
variable output_stderr ""
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available
#if a thread::send is done from the commandline in a codethread - Tcl will
if {"code" ni [interp children] || ![info exists replthread_cond]} {
#in case someone tries calling from codethread directly - don't do anything or change any state
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful)
#if called directly - the context will be within the first 'code' interp.
#inappropriate caller could add superfluous entries to shellfilter stack if function errors out
#inappropriate caller could affect tsv vars (if their interp allows that anyway)
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread"
return
}
set outstack [list]
set errstack [list]
upvar ::punk::config::running running_config
if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} {
lappend outstack [interp eval code [list shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]]
}
lappend outstack [interp eval code [list shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]]
if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} {
lappend errstack [interp eval code [list shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]]
# #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]]
}
lappend errstack [interp eval code [list shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]]
#an experiment
#set errhandle [shellfilter::stack::item_tophandle stderr]
#interp transfer "" $errhandle code
set scope [interp eval code [list set ::punk::ns::ns_current]]
set status [catch {
interp eval code [list tcl::namespace::inscope $scope $script]
} result]
flush stdout
flush stderr
#interp transfer code $errhandle ""
#flush $errhandle
set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end]
set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end]
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]"
set tid [thread::id]
tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar]
tsv::set codethread_$tid status $status
tsv::set codethread_$tid result $result
tsv::set codethread_$tid errorcode $::errorCode
#only remove from shellfilter::stack the items we added to stack in this function
foreach s [lreverse $outstack] {
interp eval code [list shellfilter::stack::remove stdout $s]
}
foreach s [lreverse $errstack] {
interp eval code [list shellfilter::stack::remove stderr $s]
}
thread::cond notify $replthread_cond
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::repl::codethread::lib {
tcl::namespace::export *
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::repl::codethread::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::repl::codethread::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
tcl::namespace::eval punk::repl::codethread::system {
#*** !doctools
#[subsection {Namespace punk::repl::codethread::system}]
#[para] Internal functions that are not part of the API
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread {
variable pkg punk::repl::codethread
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

237
src/bootsupport/modules/punk/unixywindows-0.1.0.tm

@ -0,0 +1,237 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application punk::unixywindows 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
#for illegalname_test
package require punk::winpath
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::unixywindows {
#'cached' name to make obvious it could be out of date - and to distinguish from unixyroot arg
variable cachedunixyroot ""
#-----------------
#e.g something like c:/Users/geek/scoop/apps/msys2/current c:/msys2
proc get_unixyroot {} {
variable cachedunixyroot
if {![string length $cachedunixyroot]} {
if {![catch {
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context.
set cachedunixyroot [punk::objclone $result]
file pathtype $cachedunixyroot; #this call causes the int-rep to be path
#set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display
} errM]} {
} else {
puts stderr "Warning: Failed to determine base for unix-like paths - using default of c:/msys2"
file pathtype [set cachedunixyroot [punk::objclone "c:/msys2"]]
}
}
#will have been shimmered from string to 'path' internal rep by 'file pathtype' call
#let's return a different copy as it's so easy to lose path-rep
set copy [punk::objclone $cachedunixyroot]
return $copy
}
proc refresh_unixyroot {} {
variable cachedunixyroot
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context.
set cachedunixyroot [punk::objclone $result]
file pathtype $cachedunixyroot; #this call causes the int-rep to be path
set copy [punk::objclone $cachedunixyroot]
return $copy
}
proc set_unixyroot {windows_path} {
variable cachedunixyroot
file pathtype $windows_path
set cachedunixyroot [punk::objclone $windows_path]
#return the original - but probably int-rep will have shimmered to path even if started out as string
#- that's probably what we want. Caller can use as string or path without affecting cachedunixyroot
return $windows_path
}
proc windir {path} {
if {$path eq "~"} {
#as the tilde hasn't been normalized.. we can't assume we're running on the actual platform
return ~/..
}
return [file dirname [towinpath $path]]
}
#REVIEW high-coupling
proc cdwin {path} {
set path [towinpath $path]
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
if {[llength [info commands ::punk::console::titleset]]} {
::punk::console::titleset $path
}
}
cd $path
}
proc cdwindir {path} {
set path [towinpath $path]
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
if {[llength [info commands ::punk::console::titleset]]} {
::punk::console::titleset $path
}
}
cd [file dirname $path]
}
#NOTE - this is an expensive operation - avoid where possible.
#review - is this intended to be useful/callable on non-windows platforms?
#it should in theory be useable from another platform that wants to create a path for use on windows.
#In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid)
#review zipfs:// other uri schemes?
proc towinpath {unixypath {unixyroot ""}} {
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative)
#(Tcl is also somewhat broken as at 2023 as far as volume relative paths - process can get out of sync with tcl if cd to a vol relative path is used)
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD.
#e.g there is potential confusion when there is a c folder on c: drive (c:/c)
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd.
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong..
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume.
#
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways.
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common
#
#convert /c/etc to C:/etc
set re_slash_x_slash {^/([[:alpha:]]){1}/.*}
set re_slash_else {^/([[:alpha:]]*)(.*)}
set volumes [file volumes]
#exclude things like //zipfs:/ ??
set driveletters [list]
foreach v $volumes {
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} {
lappend driveletters $letter
}
}
#puts stderr "->$driveletters"
set path [punk::objclone $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument
set supplied_pathtype [file pathtype $path] ;#we don't care about the pathtype so much as the act of making this call shimmers to a path internal-rep
#copy of var that we can treat as a string without affecting path rep
#Note that some but not all read operations will lose path rep e.g 'string length $x' will lose any path-rep $x had, (but 'string equal $x something' won't)
#Todo - make int-rep tests to check stability of these behaviours across Tcl versions!
set strcopy_path [punk::objclone $path]
set str_newpath ""
set have_pathobj 0
if {[regexp $re_slash_x_slash $strcopy_path _ letter]} {
#upper case appears to be windows canonical form
set str_newpath [string toupper $letter]:/[string range $strcopy_path 3 end]
} elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $strcopy_path] _ letter]} {
set str_newpath [string toupper $letter]:/[string range $strcopy_path 7 end]
} elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $strcopy_path] _ letter]} {
set str_newpath [string toupper $letter]:/
} elseif {[regexp $re_slash_else $strcopy_path _ firstpart remainder]} {
#could be for example /c or /something/users
if {[string length $firstpart] == 1} {
set letter $firstpart
set str_newpath [string toupper $letter]:/
} else {
#according to regex we have a single leading slash
set str_tail [string range $strcopy_path 1 end]
if {$unixyroot eq ""} {
set unixyroot [get_unixyroot]
} else {
file pathtype $unixyroot; #side-effect generates int-rep of type path )
}
set pathobj [file join $unixyroot $str_tail]
file pathtype $pathobj
set have_pathobj 1
}
}
if {!$have_pathobj} {
if {$str_newpath eq ""} {
#dunno - pass through
set pathobj $path
} else {
set pathobj [punk::objclone $str_newpath]
file pathtype $pathobj
}
}
#puts stderr "=> $path"
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder
#
#By now file normalize shouldn't do too many shannanigans related to cwd..
#We want it to look at cwd for relative paths..
#but we don't consider things like /c/Users to be relative even on windows where it would normally mean a volume-relative path e.g c:/c/Users if cwd happens to be somewhere on C: at the time.
#if {![file exists [file dirname $path]]} {
# set path [file normalize $path]
# #may still not exist.. that's ok.
#}
#file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name
#2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes
if {[punk::winpath::illegalname_test $pathobj]} {
set pathobj [punk::winpath::illegalname_fix $pathobj]
}
return $pathobj
}
#----------------------------------------------
#leave the unixywindows related aliases available on all platforms
#interp alias {} cdwin {} punk::unixywindows::cdwin
#interp alias {} cdwindir {} punk::unixywindoes::cdwindir
#interp alias {} towinpath {} punk::unixywindows::towinpath
#interp alias {} windir {} punk::unixywindows::windir
#----------------------------------------------
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::unixywindows [namespace eval punk::unixywindows {
variable version
set version 0.1.0
}]
return

239
src/bootsupport/modules/punkapp-0.1.tm

@ -0,0 +1,239 @@
#utilities for punk apps to call
package provide punkapp [namespace eval punkapp {
variable version
set version 0.1
}]
namespace eval punkapp {
variable result
variable waiting "no"
proc hide_dot_window {} {
#alternative to wm withdraw .
#see https://wiki.tcl-lang.org/page/wm+withdraw
wm geometry . 1x1+0+0
wm overrideredirect . 1
wm transient .
}
proc is_toplevel {w} {
if {![llength [info commands winfo]]} {
return 0
}
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]}
}
proc get_toplevels {{w .}} {
if {![llength [info commands winfo]]} {
return [list]
}
set list {}
if {[is_toplevel $w]} {
lappend list $w
}
foreach w [winfo children $w] {
lappend list {*}[get_toplevels $w]
}
return $list
}
proc make_toplevel_next {prefix} {
set top [get_toplevel_next $prefix]
return [toplevel $top]
}
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase?
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix
proc get_toplevel_next {prefix} {
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> ""
}
proc exit {{toplevel ""}} {
variable waiting
variable result
variable default_result
set toplevels [get_toplevels]
if {[string length $toplevel]} {
set wposn [lsearch $toplevels $toplevel]
if {$wposn > 0} {
destroy $toplevel
}
} else {
#review
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
puts stderr "punkapp::exit called without toplevel - showing console"
show_console
return 0
} else {
puts stderr "punkapp::exit called without toplevel - exiting"
if {$waiting ne "no"} {
if {[info exists result(shell)]} {
set temp [set result(shell)]
unset result(shell)
set waiting $temp
} else {
set waiting ""
}
} else {
::exit
}
}
}
set controllable [get_user_controllable_toplevels]
if {![llength $controllable]} {
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
show_console
} else {
if {$waiting ne "no"} {
if {[info exists result(shell)]} {
set temp [set result(shell)]
unset result(shell)
set waiting $temp
} elseif {[info exists result($toplevel)]} {
set temp [set result($toplevel)]
unset result($toplevel)
set waiting $temp
} elseif {[info exists default_result]} {
set temp $default_result
unset default_result
set waiting $temp
} else {
set waiting ""
}
} else {
::exit
}
}
}
}
proc close_window {toplevel} {
wm withdraw $toplevel
if {![llength [get_user_controllable_toplevels]]} {
punkapp::exit $toplevel
}
destroy $toplevel
}
proc wait {args} {
variable waiting
variable default_result
if {[dict exists $args -defaultresult]} {
set default_result [dict get $args -defaultresult]
}
foreach t [punkapp::get_toplevels] {
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} {
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t]
}
}
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
puts stderr "repl eventloop seems to be running - punkapp::wait not required"
} else {
if {$waiting eq "no"} {
set waiting "waiting"
vwait ::punkapp::waiting
return $::punkapp::waiting
}
}
}
#A window can be 'visible' according to this - but underneath other windows etc
#REVIEW - change name?
proc get_visible_toplevels {{w .}} {
if {![llength [info commands winfo]]} {
return [list]
}
set list [get_toplevels $w]
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}]
set mapped [concat {*}$mapped] ;#ignore {}
set visible [list]
foreach m $mapped {
if {[wm overrideredirect $m] == 0 } {
lappend visible $m
} else {
if {[winfo height $m] >1 && [winfo width $m] > 1} {
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible
lappend visible $m
}
}
}
return $visible
}
proc get_user_controllable_toplevels {{w .}} {
set visible [get_visible_toplevels $w]
set controllable [list]
foreach v $visible {
if {[wm overrideredirect $v] == 0} {
lappend controllable $v
}
}
#only return visible windows with overrideredirect == 0 because there exists some user control.
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily
return $controllable
}
proc hide_console {args} {
set opts [dict create -force 0]
if {([llength $args] % 2) != 0} {
error "hide_console expects pairs of arguments. e.g -force 1"
}
#set known_opts [dict keys $defaults]
foreach {k v} $args {
switch -- $k {
-force {
dict set opts $k $v
}
default {
error "Unrecognised options '$k' known options: [dict keys $opts]"
}
}
}
set force [dict get $opts -force]
if {!$force} {
if {![llength [get_user_controllable_toplevels]]} {
puts stderr "Cannot hide console while no user-controllable windows available"
return 0
}
}
if {$::tcl_platform(platform) eq "windows"} {
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway.
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way.
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though.
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call)
package require twapi
set h [twapi::get_console_window]
set pid [twapi::get_window_process $h]
set pinfo [twapi::get_process_info $pid -name]
set pname [dict get $pinfo -name]
set wstyle [twapi::get_window_style $h]
#tclkitsh/tclsh?
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} {
twapi::hide_window $h
return 1
} else {
puts stderr "punkapp::hide_console unable to hide this type of console window"
return 0
}
} else {
#todo
puts stderr "punkapp::hide_console unimplemented on this platform (todo)"
return 0
}
}
proc show_console {} {
if {$::tcl_platform(platform) eq "windows"} {
package require twapi
if {![catch {set h [twapi::get_console_window]} errM]} {
twapi::show_window $h -activate -normal
} else {
#no console - assume launched from something like wish?
catch {console show}
}
} else {
#todo
puts stderr "punkapp::show_console unimplemented on this platform"
}
}
}

333
src/bootsupport/modules/punkcheck/cli-0.1.0.tm

@ -0,0 +1,333 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application punkcheck::cli 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
package require punk::mix::util
namespace eval punkcheck::cli {
namespace ensemble create
#package require punk::overlay
#punk::overlay::import_commandset debug. ::punk:mix::commandset::debug
#init proc required - used for lazy loading of commandsets
variable initialised 0
proc _init {args} {
variable initialised
if {$initialised} {
return
}
puts stderr "punkcheck::cli::init $args"
set initialised 1
}
proc help {args} {
set basehelp [punk::mix::base help {*}$args]
return $basehelp
}
proc paths {{path {}}} {
if {$path eq {}} { set path [pwd] }
set search_from $path
set bottom_to_top [list]
while {[string length [set pcheck_file [punkcheck::cli::lib::find_nearest_file $search_from]]]} {
set pcheck_folder [file dirname $pcheck_file]
lappend bottom_to_top $pcheck_file
set search_from [file dirname $pcheck_folder]
}
return $bottom_to_top
}
#todo! - group by fileset
proc status {{path {}}} {
if {$path eq {}} { set path [pwd] }
set fullpath [file normalize $path]
set ftype [file type $fullpath]
set files [list]
if {$ftype eq "file"} {
set container [file dirname $fullpath]
lappend files $fullpath
} else {
set container $fullpath
#vfs can mask mounted files - so we can't just use 'file type' or glob with -type f
##set files [glob -nocomplain -dir $fullpath -type f *]
package require punk::nav::fs
set folderinfo [punk::nav::fs::dirfiles_dict $fullpath]
set files [concat [dict get $folderinfo files] [dict get $folderinfo underlayfiles]]
}
set punkcheck_files [paths $container]
set repodict [punk::repo::find_repo $container]
if {![llength $punkcheck_files]} {
puts stderr "No .punkcheck files found at or above this folder"
}
set table ""
set files_with_records [list]
foreach p $punkcheck_files {
set basedir [file dirname $p]
set recordlist [punkcheck::load_records_from_file $p]
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist]
foreach f $files {
set relpath [punkcheck::lib::path_relative $basedir $f]
if {[dict exists $tgt_dict $relpath]} {
set filerec [dict get $tgt_dict $relpath]
set records [punkcheck::dict_getwithdefault $filerec body [list]]
if {$ftype eq "file"} {
if {![llength $records]} {
set pcheck "(has file record but no installation entries)"
} else {
set pcheck \n
foreach irec $records {
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n
#append pcheck " $irec" \n
}
}
} else {
if {![llength $records]} {
set pcheck "(has file record but no installation entries)"
} else {
set display_records [list]
set pcheck \n
set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec]
if {[llength $latest_install_record]} {
lappend display_records $latest_install_record
}
if {$latest_install_record ne [lindex $records end]} {
lappend display_records [lindex $records end]
}
foreach irec $display_records {
append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]"
set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]]
set source_files [list]
set source_files_changed [list]
set source_folders [list]
set source_folders_changed [list]
foreach r $bodyrecords {
if {[dict get $r tag] eq "SOURCE"} {
set path [dict get $r -path]
set changed [dict get $r -changed]
switch -- [dict get $r -type] {
file {
lappend source_files $path
if {$changed} {
lappend source_files_changed $path
}
}
directory {
lappend source_folders $path
if {$changed} {
lappend source_folders_changed $path
}
}
}
}
}
if {[llength $source_files]} {
append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])"
}
if {[llength $source_folders]} {
append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])"
}
append pcheck \n
#append pcheck [punk::tdl::prettyprint [list $irec] 1] \n
#append pcheck " $irec" \n
}
}
}
append table "$f $pcheck" \n
}
}
}
return $table
}
proc status_by_file {{path {}}} {
if {$path eq {}} { set path [pwd] }
set fullpath [file normalize $path]
set ftype [file type $fullpath]
set files [list]
if {$ftype eq "file"} {
set container [file dirname $fullpath]
lappend files $fullpath
} else {
set container $fullpath
set files [glob -nocomplain -dir $fullpath -type f *]
}
set punkcheck_files [paths $container]
set repodict [punk::repo::find_repo $container]
if {![llength $punkcheck_files]} {
puts stderr "No .punkcheck files found at or above this folder"
}
set table ""
set files_with_records [list]
foreach p $punkcheck_files {
set basedir [file dirname $p]
set recordlist [punkcheck::load_records_from_file $p]
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist]
foreach f $files {
set relpath [punkcheck::lib::path_relative $basedir $f]
if {[dict exists $tgt_dict $relpath]} {
set filerec [dict get $tgt_dict $relpath]
set records [punkcheck::dict_getwithdefault $filerec body [list]]
if {$ftype eq "file"} {
if {![llength $records]} {
set pcheck "(has file record but no installation entries)"
} else {
set pcheck \n
foreach irec $records {
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n
#append pcheck " $irec" \n
}
}
} else {
if {![llength $records]} {
set pcheck "(has file record but no installation entries)"
} else {
set display_records [list]
set pcheck \n
set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec]
lappend display_records $latest_install_record
if {$latest_install_record ne [lindex $records end]} {
lappend display_records [lindex $records end]
}
foreach irec $display_records {
append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]"
set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]]
set source_files [list]
set source_files_changed [list]
set source_folders [list]
set source_folders_changed [list]
foreach r $bodyrecords {
if {[dict get $r tag] eq "SOURCE"} {
set path [dict get $r -path]
set changed [dict get $r -changed]
switch -- [dict get $r -type] {
file {
lappend source_files $path
if {$changed} {
lappend source_files_changed $path
}
}
directory {
lappend source_folders $path
if {$changed} {
lappend source_folders_changed $path
}
}
}
}
}
if {[llength $source_files]} {
append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])"
}
if {[llength $source_folders]} {
append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])"
}
append pcheck \n
#append pcheck [punk::tdl::prettyprint [list $irec] 1] \n
#append pcheck " $irec" \n
}
}
}
append table "$f $pcheck" \n
}
}
}
return $table
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punkcheck::cli::lib {
namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc
proc find_nearest_file {{path {}}} {
if {$path eq {}} { set path [pwd] }
set folder [lib::scanup $path lib::is_punkchecked_folder]
if {$folder eq ""} {
return ""
} else {
return [file join $folder .punkcheck]
}
}
proc is_punkchecked_folder {{path {}}} {
if {$path eq {}} { set path [pwd] }
foreach control {
.punkcheck
} {
set control [file join $path $control]
if {[file isfile $control]} {return 1}
}
return 0
}
proc scanup {path cmd} {
if {$path eq {}} { set path [pwd] }
#based on kettle::path::scanup
if {[file pathtype $path] eq "relative"} {
set path [file normalize $path]
}
while {1} {
# Found the proper directory, per the predicate.
if {[{*}$cmd $path]} { return $path }
# Not found, walk to parent
set new [file dirname $path]
# Stop when reaching the root.
if {$new eq $path} { return {} }
if {$new eq {}} { return {} }
# Ok, truly walk up.
set path $new
}
return {}
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punkcheck::cli {
proc _cli {args} {
#don't use tailcall - base uses info level to determine caller
::punk::mix::base::_cli {*}$args
}
variable default_command status
package require punk::mix::base
package require punk::overlay
punk::overlay::custom_from_base [namespace current] ::punk::mix::base
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punkcheck::cli [namespace eval punkcheck::cli {
variable version
set version 0.1.0
}]
return

3078
src/bootsupport/modules/shellfilter-0.1.9.tm

File diff suppressed because it is too large Load Diff

259
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argp-0.2.tm

@ -0,0 +1,259 @@
# Tcl parser for optional arguments in function calls and
# commandline arguments
#
# (c) 2001 Bastien Chevreux
# Index of exported commands
# - argp::registerArgs
# - argp::setArgDefaults
# - argp::setArgsNeeded
# - argp::parseArgs
# Internal commands
# - argp::CheckValues
# See end of file for an example on how to use
package provide argp 0.2
namespace eval argp {
variable Optstore
variable Opttypes {
boolean integer double string
}
namespace export {[a-z]*}
}
proc argp::registerArgs { func arglist } {
variable Opttypes
variable Optstore
set parentns [string range [uplevel 1 [list namespace current]] 2 end]
if { $parentns != "" } {
append caller $parentns :: $func
} else {
set caller $func
}
set cmangled [string map {:: _} $caller]
#puts $parentns
#puts $caller
#puts $cmangled
set Optstore(keys,$cmangled) {}
set Optstore(deflist,$cmangled) {}
set Optstore(argneeded,$cmangled) {}
foreach arg $arglist {
foreach {opt type default allowed} $arg {
set optindex [lsearch -glob $Opttypes $type*]
if { $optindex < 0} {
return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]"
}
set type [lindex $Opttypes $optindex]
lappend Optstore(keys,$cmangled) $opt
set Optstore(type,$opt,$cmangled) $type
set Optstore(default,$opt,$cmangled) $default
set Optstore(allowed,$opt,$cmangled) $allowed
lappend Optstore(deflist,$cmangled) $opt $default
}
}
if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} {
return -code error "Error in declaration of optional arguments.\n$res"
}
}
proc argp::setArgDefaults { func arglist } {
variable Optstore
set parentns [string range [uplevel 1 [list namespace current]] 2 end]
if { $parentns != "" } {
append caller $parentns :: $func
} else {
set caller $func
}
set cmangled [string map {:: _} $caller]
if {![info exists Optstore(deflist,$cmangled)]} {
return -code error "Arguments for $caller not registered yet."
}
set Optstore(deflist,$cmangled) {}
foreach {opt default} $arglist {
if {![info exists Optstore(default,$opt,$cmangled)]} {
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)"
}
set Optstore(default,$opt,$cmangled) $default
}
# set the new defaultlist
foreach opt $Optstore(keys,$cmangled) {
lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled)
}
}
proc argp::setArgsNeeded { func arglist } {
variable Optstore
set parentns [string range [uplevel 1 [list namespace current]] 2 end]
if { $parentns != "" } {
append caller $parentns :: $func
} else {
set caller $func
}
set cmangled [string map {:: _} $caller]
#append caller $parentns :: $func
#set cmangled ${parentns}_$func
if {![info exists Optstore(deflist,$cmangled)]} {
return -code error "Arguments for $caller not registered yet."
}
set Optstore(argneeded,$cmangled) {}
foreach opt $arglist {
if {![info exists Optstore(default,$opt,$cmangled)]} {
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)"
}
lappend Optstore(argneeded,$cmangled) $opt
}
}
proc argp::parseArgs { args } {
variable Optstore
if {[llength $args] == 0} {
upvar args a opts o
} else {
upvar args a [lindex $args 0] o
}
if { [ catch { set caller [lindex [info level -1] 0]}]} {
set caller "main program"
set cmangled ""
} else {
set cmangled [string map {:: _} $caller]
}
if {![info exists Optstore(deflist,$cmangled)]} {
return -code error "Arguments for $caller not registered yet."
}
# set the defaults
array set o $Optstore(deflist,$cmangled)
# but unset the needed arguments
foreach key $Optstore(argneeded,$cmangled) {
catch { unset o($key) }
}
foreach {key val} $a {
if {![info exists Optstore(type,$key,$cmangled)]} {
return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)"
}
switch -exact -- $Optstore(type,$key,$cmangled) {
boolean -
integer {
if { $val == "" } {
return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value."
}
if { ![string is $Optstore(type,$key,$cmangled) $val]} {
return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value."
}
}
double {
if { $val == "" } {
return -code error "$caller, $key empty string is not double value."
}
if { ![string is double $val]} {
return -code error "$caller, $key $val is not double value."
}
if { [string is integer $val]} {
set val [expr {$val + .0}]
}
}
default {
}
}
set o($key) $val
}
foreach key $Optstore(argneeded,$cmangled) {
if {![info exists o($key)]} {
return -code error "$caller, needed argument $key was not given."
}
}
if { [catch { CheckValues $caller $cmangled [array get o]} err]} {
return -code error $err
}
return
}
proc argp::CheckValues { caller cmangled checklist } {
variable Optstore
#puts "Checking $checklist"
foreach {key val} $checklist {
if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } {
switch -exact -- $Optstore(type,$key,$cmangled) {
string {
if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} {
return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)"
}
}
double -
integer {
set found 0
foreach range $Optstore(allowed,$key,$cmangled) {
if {[llength $range] == 1} {
if { $val == [lindex $range 0] } {
set found 1
break
}
} elseif {[llength $range] == 2} {
set low [lindex $range 0]
set high [lindex $range 1]
if { ![string is integer $low] \
&& [string compare "-" $low] != 0} {
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not \u00b4-\u00b4: $range"
}
if { ![string is integer $high] \
&& [string compare "+" $high] != 0} {
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not \u00b4+\u00b4: $range"
}
if {[string compare "-" $low] == 0} {
if { [string compare "+" $high] == 0 \
|| $val <= $high } {
set found 1
break
}
}
if { $val >= $low } {
if {[string compare "+" $high] == 0 \
|| $val <= $high } {
set found 1
break
}
}
} else {
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range"
}
}
if { $found == 0 } {
return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)"
}
}
}
}
}
}

306
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/debug-1.0.6.tm

@ -0,0 +1,306 @@
# Debug - a debug narrative logger.
# -- Colin McCormack / originally Wub server utilities
#
# Debugging areas of interest are represented by 'tokens' which have
# independantly settable levels of interest (an integer, higher is more detailed)
#
# Debug narrative is provided as a tcl script whose value is [subst]ed in the
# caller's scope if and only if the current level of interest matches or exceeds
# the Debug call's level of detail. This is useful, as one can place arbitrarily
# complex narrative in code without unnecessarily evaluating it.
#
# TODO: potentially different streams for different areas of interest.
# (currently only stderr is used. there is some complexity in efficient
# cross-threaded streams.)
# # ## ### ##### ######## ############# #####################
## Requisites
package require Tcl 8.5-
namespace eval ::debug {
namespace export -clear \
define on off prefix suffix header trailer \
names 2array level setting parray pdict \
nl tab hexl
namespace ensemble create -subcommands {}
}
# # ## ### ##### ######## ############# #####################
## API & Implementation
proc ::debug::noop {args} {}
proc ::debug::debug {tag message {level 1}} {
variable detail
if {$detail($tag) < $level} {
#puts stderr "$tag @@@ $detail($tag) >= $level"
return
}
variable prefix
variable suffix
variable header
variable trailer
variable fds
if {[info exists fds($tag)]} {
set fd $fds($tag)
} else {
set fd stderr
}
# Assemble the shown text from the user message and the various
# prefixes and suffices (global + per-tag).
set themessage ""
if {[info exists prefix(::)]} { append themessage $prefix(::) }
if {[info exists prefix($tag)]} { append themessage $prefix($tag) }
append themessage $message
if {[info exists suffix($tag)]} { append themessage $suffix($tag) }
if {[info exists suffix(::)]} { append themessage $suffix(::) }
# Resolve variables references and command invokations embedded
# into the message with plain text.
set code [catch {
set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]]
set sheader [uplevel 1 [list ::subst -nobackslashes $header]]
set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]]
} __ eo]
# And dump an internal error if that resolution failed.
if {$code} {
if {[catch {
set caller [info level -1]
}]} { set caller GLOBAL }
if {[string length $caller] >= 1000} {
set caller "[string range $caller 0 200]...[string range $caller end-200 end]"
}
foreach line [split $caller \n] {
puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)"
}
return
}
# From here we have a good message to show. We only shorten it a
# bit if its a bit excessive in size.
if {[string length $smessage] > 4096} {
set head [string range $smessage 0 2048]
set tail [string range $smessage end-2048 end]
set smessage "${head}...(truncated)...$tail"
}
foreach line [split $smessage \n] {
puts $fd "$sheader$tag | $line$strailer"
}
return
}
# names - return names of debug tags
proc ::debug::names {} {
variable detail
return [lsort [array names detail]]
}
proc ::debug::2array {} {
variable detail
set result {}
foreach n [lsort [array names detail]] {
if {[interp alias {} debug.$n] ne "::debug::noop"} {
lappend result $n $detail($n)
} else {
lappend result $n -$detail($n)
}
}
return $result
}
# level - set level and fd for tag
proc ::debug::level {tag {level ""} {fd {}}} {
variable detail
# TODO: Force level >=0.
if {$level ne ""} {
set detail($tag) $level
}
if {![info exists detail($tag)]} {
set detail($tag) 1
}
variable fds
if {$fd ne {}} {
set fds($tag) $fd
}
return $detail($tag)
}
proc ::debug::header {text} { variable header $text }
proc ::debug::trailer {text} { variable trailer $text }
proc ::debug::define {tag} {
if {[interp alias {} debug.$tag] ne {}} return
off $tag
return
}
# Set a prefix/suffix to use for tag.
# The global (tag-independent) prefix/suffix is adressed through tag '::'.
# This works because colon (:) is an illegal character for user-specified tags.
proc ::debug::prefix {tag {theprefix {}}} {
variable prefix
set prefix($tag) $theprefix
if {[interp alias {} debug.$tag] ne {}} return
off $tag
return
}
proc ::debug::suffix {tag {theprefix {}}} {
variable suffix
set suffix($tag) $theprefix
if {[interp alias {} debug.$tag] ne {}} return
off $tag
return
}
# turn on debugging for tag
proc ::debug::on {tag {level ""} {fd {}}} {
variable active
set active($tag) 1
level $tag $level $fd
interp alias {} debug.$tag {} ::debug::debug $tag
return
}
# turn off debugging for tag
proc ::debug::off {tag {level ""} {fd {}}} {
variable active
set active($tag) 1
level $tag $level $fd
interp alias {} debug.$tag {} ::debug::noop
return
}
proc ::debug::setting {args} {
if {[llength $args] == 1} {
set args [lindex $args 0]
}
set fd stderr
if {[llength $args] % 2} {
set fd [lindex $args end]
set args [lrange $args 0 end-1]
}
foreach {tag level} $args {
if {$level > 0} {
level $tag $level $fd
interp alias {} debug.$tag {} ::debug::debug $tag
} else {
level $tag [expr {-$level}] $fd
interp alias {} debug.$tag {} ::debug::noop
}
}
return
}
# # ## ### ##### ######## ############# #####################
## Convenience commands.
# Format arrays and dicts as multi-line message.
# Insert newlines and tabs.
proc ::debug::nl {} { return \n }
proc ::debug::tab {} { return \t }
proc ::debug::parray {a {pattern *}} {
upvar 1 $a array
if {![array exists array]} {
error "\"$a\" isn't an array"
}
pdict [array get array] $pattern
}
proc ::debug::pdict {dict {pattern *}} {
set maxl 0
set names [lsort -dict [dict keys $dict $pattern]]
foreach name $names {
if {[string length $name] > $maxl} {
set maxl [string length $name]
}
}
set maxl [expr {$maxl + 2}]
set lines {}
foreach name $names {
set nameString [format (%s) $name]
lappend lines [format "%-*s = %s" \
$maxl $nameString \
[dict get $dict $name]]
}
return [join $lines \n]
}
proc ::debug::hexl {data {prefix {}}} {
set r {}
# Convert the data to hex and to characters.
binary scan $data H*@0a* hexa asciia
# Replace non-printing characters in the data with dots.
regsub -all -- {[^[:graph:] ]} $asciia {.} asciia
# Pad with spaces to a full multiple of 32/16.
set n [expr {[string length $hexa] % 32}]
if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] }
#puts "pad H [expr {32-$n}]"
set n [expr {[string length $asciia] % 32}]
if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] }
#puts "pad A [expr {32-$n}]"
# Reassemble formatted, in groups of 16 bytes/characters.
# The hex part is handled in groups of 32 nibbles.
set addr 0
while {[string length $hexa]} {
# Get front group of 16 bytes each.
set hex [string range $hexa 0 31]
set ascii [string range $asciia 0 15]
# Prep for next iteration
set hexa [string range $hexa 32 end]
set asciia [string range $asciia 16 end]
# Convert the hex to pairs of hex digits
regsub -all -- {..} $hex {& } hex
# Add the hex and latin-1 data to the result buffer
append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n
incr addr 16
}
# And done
return $r
}
# # ## ### ##### ######## ############# #####################
namespace eval debug {
variable detail ; # map: TAG -> level of interest
variable prefix ; # map: TAG -> message prefix to use
variable suffix ; # map: TAG -> message suffix to use
variable fds ; # map: TAG -> handle of open channel to log to.
variable header {} ; # per-line heading, subst'ed
variable trailer {} ; # per-line ending, subst'ed
# Notes:
# - The tag '::' is reserved. "prefix" and "suffix" use it to store
# the global message prefix / suffix.
# - prefix and suffix are applied per message.
# - header and trailer are per line. And should not generate multiple lines!
}
# # ## ### ##### ######## ############# #####################
## Ready
package provide debug 1.0.6
return

2714
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/flagfilter-0.3.tm

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,322 @@
package provide funcl [namespace eval funcl {
variable version
set version 0.1
}]
#funcl = function list (nested call structure)
#
#a basic functional composition o combinator
#o(f,g)(x) == f(g(x))
namespace eval funcl {
#from punk
proc arg_is_script_shaped {arg} {
if {[string first " " $arg] >= 0} {
return 1
} elseif {[string first \n $arg] >= 0} {
return 1
} elseif {[string first ";" $arg] >= 0} {
return 1
} elseif {[string first \t $arg] >= 0} {
return 1
} else {
return 0
}
}
proc o args {
set closing [string repeat {]} [expr [llength $args]-1]]
set body "[join $args { [}] \$data $closing"
return $body
}
proc o_ args {
set body ""
set tails [lrepeat [llength $args] ""]
puts stdout "tails: $tails"
set end [lindex $args end]
if {[llength $end] == 1 && [arg_is_script_shaped $end]} {
set endfunc [string map "<end> $end" {uplevel 1 [list if 1 <end> ]}]
} else {
set endfunc $end
}
if {[llength $args] == 1} {
return $endfunc
}
set wrap { [}
append wrap $endfunc
append wrap { ]}
set i 0
foreach cmdlist [lrange $args 0 end-1] {
set is_script 0
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} {
set is_script 1
set script [lindex $cmdlist 0]
}
set t ""
if {$i > 0} {
append body { [}
}
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
if {$i == [expr {[llength $args] -2}]} {
#append body " \$data"
append body " $wrap"
}
if {$i > 0} {
set t {]}
}
} else {
append body [lrange $cmdlist 0 $posn-1]
if {$i == [expr {[llength $args] -2}]} {
#append body " \$data"
append body " $wrap"
}
set t [lrange $cmdlist $posn+1 end]
if {$i > 0} {
append t { ]}
}
}
lset tails $i $t
incr i
}
append body [join [lreverse $tails] " "]
puts stdout "tails: $tails"
return $body
}
#review - consider _call -- if count > 1 then they must all be callable cmdlists(?)
# what does it mean to have additional _fn wrapper with no other elements? (no actual function)
#e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}}
# what type indicates running subtrees in parallel vs sequentially?
# any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc.
#
#
# accept or return a funcl (or funcltree if multiple funcls in one commandlist)
# also accept/return a call - return empty list if passed a call
proc next_funcl {funcl_or_tree} {
if {[lindex $funcl_or_tree 0] eq "_call"} {
return [list]
}
if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} {
set funcl $funcl_or_tree
} else {
error "funcltree not implemented"
}
set count [lindex $funcl 1]
if {$count == 0} {
#null funcl.. what is it? metadata/placeholder?
return $funcl
}
set indices [lrange $funcl 2 [expr {1 + $count}]]
set i 0
foreach idx $indices {
if {$i > 0} {
#todo - return a funcltree
error "multi funcl not implemented"
}
set next [lindex $funcl $idx]
incr i
}
return $next
}
#convert a funcl to a tcl script
proc funcl_script {funcl} {
if {![llength $funcl]} {
return ""
}
set body ""
set tails [list]
set type [lindex $funcl 0]
if {$type ni [list "_fn" "_call"]} {
#todo - handle funcltree
error "type $type not implemented"
}
#only count of 1 with index 3 supported(?)
if {$type eq "_call"} {
#leaf
set cmdlist [lindex $funcl 3]
return $cmdlist
}
#we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times.
#by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?)
# we would still need to maintain state to stitch it back together once returned from a subtree..
# ie multiple tail parts
set count [lindex $funcl 1]
if {$count == 1} {
set idx [lindex $funcl 2]
if {$idx == 3} {
set cmdlist_pre [list]
} else {
set cmdlist_pre [lrange $funcl 3 $idx-1]
}
append body $cmdlist_pre
set t [lrange $funcl $idx+1 end]
lappend tails $t
} else {
#??
error "funcl_script branching not yet supported"
}
set get_next 1
set i 1
while {$get_next} {
set funcl [next_funcl $funcl]
if {![llength $funcl]} {
set get_next 0
}
lassign $funcl type count idx ;#todo support count > 1
if {$type eq "_call"} {
set get_next 0
}
set t ""
if {$type eq "_call"} {
append body { [}
append body [lindex $funcl $idx]
append body { ]}
} else {
append body { [}
if {$idx == 3} {
set cmdlist_pre [list]
} else {
set cmdlist_pre [lrange $funcl 3 $idx-1]
}
append body $cmdlist_pre
set t [lrange $funcl $idx+1 end]
lappend tails $t
lappend tails { ]}
}
incr i
}
append body [join [lreverse $tails] " "]
#puts stdout "tails: $tails"
return $body
}
interp alias "" o_of "" funcl::o_of_n 1
#o_of_n
#tcl list rep o combinator
#
# can take lists of ordinary commandlists, scripts and funcls
# _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg)
# _fn 0 indicates next item is an unwrapped commandlist (terminal command)
#
#o_of is equivalent to o_of_n 1 (1 argument o combinator)
#last n args are passed to the prior function
#e.g for n=1 f a b = f(a(b))
#e.g for n=2, e f a b = e(f(a b))
proc o_of_n {n args} {
puts stdout "o_of_n '$args'"
if {$n != 1} {
error "o_of_n only implemented for 1 sub-funcl"
}
set comp [list] ;#composition list
set end [lindex $args end]
if {[lindex $end 0] in {_fn _call}]} {
#is_funcl
set endfunc [lindex $args end]
} else {
if {[llength $end] == 1 && [arg_is_script_shaped $end]} {
#set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}]
set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]]
} else {
set endfunc [list _call 1 3 [list {*}$end]]
}
}
if {[llength $args] == 1} {
return $endfunc
}
set comp $endfunc
set revlist [lreverse [lrange $args 0 end-1]]
foreach cmdlist $revlist {
puts stderr "o_of_n >>-- $cmdlist"
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} {
set is_script 1
set script [lindex $cmdlist 0]
set arglist [list data]
set comp [list _fn 1 6 call_script $script $arglist $comp]
} else {
set posn1 [expr {[llength $cmdlist] + 2 + $n}]
set comp [list _fn $n $posn1 {*}$cmdlist $comp]
}
}
return $comp
}
proc call_script {script argnames args} {
uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]]
}
proc funcl_script_test {scr} {
do_funcl_script_test $scr
}
proc do_funcl_script_test {scr} {
#set j "in do_funcl_script_test"
#set data "xxx"
#puts '$scr'
if 1 $scr
}
#standard o_ with no script-handling
proc o_plain args {
set body ""
set i 0
set tails [lrepeat [llength $args] ""]
#puts stdout "tails: $tails"
foreach cmdlist $args {
set t ""
if {$i > 0} {
append body { [}
}
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
if {$i == [expr {[llength $args] -1}]} {
append body " \$data"
}
if {$i > 0} {
set t {]}
}
} else {
append body [lrange $cmdlist 0 $posn-1]
if {$i == [expr {[llength $args] -1}]} {
append body " \$data"
}
set t [lrange $cmdlist $posn+1 end]
if {$i > 0} {
append t { ]}
}
}
lset tails $i $t
incr i
}
append body [join [lreverse $tails] " "]
#puts stdout "tails: $tails"
return $body
}
#timings suggest no faster to split out the first item from the cmdlist loop
}

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

@ -2,18 +2,29 @@
#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project #bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project
#They must be already built, so generally shouldn't come directly from src/modules. #They must be already built, so generally shouldn't come directly from src/modules.
#we want showdict - but it needs punk pipeline notation.
#this requires pulling in punk - which brings in lots of other stuff
#The original idea was that bootsupport could be a subset - but in practice we seem to need pretty much everything?
#we still get the advantage that the bootsupport modules can be updated independently (less frequently - after testing)
#each entry - base module #each entry - base module
set bootsupport_modules [list\ set bootsupport_modules [list\
src/vendormodules commandstack\ src/vendormodules commandstack\
src/vendormodules cksum\ src/vendormodules cksum\
src/vendormodules debug\
src/vendormodules dictutils\ src/vendormodules dictutils\
src/vendormodules fauxlink\ src/vendormodules fauxlink\
src/vendormodules fileutil\ src/vendormodules fileutil\
src/vendormodules http\ src/vendormodules http\
src/vendormodules md5\ src/vendormodules md5\
src/vendormodules metaface\
src/vendormodules modpod\ src/vendormodules modpod\
src/vendormodules oolib\ src/vendormodules oolib\
src/vendormodules overtype\ src/vendormodules overtype\
src/vendormodules pattern\
src/vendormodules patterncmd\
src/vendormodules patternlib\
src/vendormodules patternpredator2\
src/vendormodules sha1\ src/vendormodules sha1\
src/vendormodules tomlish\ src/vendormodules tomlish\
src/vendormodules test::tomlish\ src/vendormodules test::tomlish\
@ -25,8 +36,15 @@ set bootsupport_modules [list\
src/vendormodules textutil::trim\ src/vendormodules textutil::trim\
src/vendormodules textutil::wcswidth\ src/vendormodules textutil::wcswidth\
src/vendormodules uuid\ src/vendormodules uuid\
modules punkcheck\ modules argp\
modules flagfilter\
modules funcl\
modules natsort\ modules natsort\
modules punk\
modules punkapp\
modules punkcheck\
modules punkcheck::cli\
modules punk::aliascore\
modules punk::ansi\ modules punk::ansi\
modules punk::assertion\ modules punk::assertion\
modules punk::args\ modules punk::args\
@ -35,6 +53,7 @@ set bootsupport_modules [list\
modules punk::cap::handlers::scriptlibs\ modules punk::cap::handlers::scriptlibs\
modules punk::cap::handlers::templates\ modules punk::cap::handlers::templates\
modules punk::char\ modules punk::char\
modules punk::config\
modules punk::console\ modules punk::console\
modules punk::du\ modules punk::du\
modules punk::encmime\ modules punk::encmime\
@ -46,6 +65,7 @@ set bootsupport_modules [list\
modules punk::mix::cli\ modules punk::mix::cli\
modules punk::mix::util\ modules punk::mix::util\
modules punk::mix::templates\ modules punk::mix::templates\
modules punk::repl::codethread\
modules punk::mix::commandset::buildsuite\ modules punk::mix::commandset::buildsuite\
modules punk::mix::commandset::debug\ modules punk::mix::commandset::debug\
modules punk::mix::commandset::doc\ modules punk::mix::commandset::doc\
@ -55,14 +75,18 @@ set bootsupport_modules [list\
modules punk::mix::commandset::project\ modules punk::mix::commandset::project\
modules punk::mix::commandset::repo\ modules punk::mix::commandset::repo\
modules punk::mix::commandset::scriptwrap\ modules punk::mix::commandset::scriptwrap\
modules punk::mod\
modules punk::nav::fs\
modules punk::ns\ modules punk::ns\
modules punk::overlay\ modules punk::overlay\
modules punk::path\ modules punk::path\
modules punk::packagepreference\ modules punk::packagepreference\
modules punk::repo\ modules punk::repo\
modules punk::tdl\ modules punk::tdl\
modules punk::unixywindows\
modules punk::zip\ modules punk::zip\
modules punk::winpath\ modules punk::winpath\
modules shellfilter\
modules textblock\ modules textblock\
modules natsort\ modules natsort\
modules oolib\ modules oolib\

6411
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.5.tm

File diff suppressed because it is too large Load Diff

1285
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/pattern-1.2.4.tm

File diff suppressed because it is too large Load Diff

645
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm

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

2590
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternlib-1.2.6.tm

File diff suppressed because it is too large Load Diff

754
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm

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

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

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,272 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application punk::aliascore 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::aliascore 0 0.1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require punk::aliascore]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::aliascore
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::aliascore
#[list_begin itemized]
package require Tcl 8.6-
#*** !doctools
#[item] [package {Tcl 8.6}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::aliascore::class {
# #*** !doctools
# #[subsection {Namespace punk::aliascore::class}]
# #[para] class definitions
# if {[info commands [namespace current]::interface_sample1] eq ""} {
# #*** !doctools
# #[list_begin enumerated]
#
# # oo::class create interface_sample1 {
# # #*** !doctools
# # #[enum] CLASS [class interface_sample1]
# # #[list_begin definitions]
#
# # method test {arg1} {
# # #*** !doctools
# # #[call class::interface_sample1 [method test] [arg arg1]]
# # #[para] test method
# # puts "test: $arg1"
# # }
#
# # #*** !doctools
# # #[list_end] [comment {-- end definitions interface_sample1}]
# # }
#
# #*** !doctools
# #[list_end] [comment {--- end class enumeration ---}]
# }
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::aliascore {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
variable aliases
#use absolute ns ie must be prefixed with ::
#single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased
#functions must be in export list of their source namespace
set aliases [tcl::dict::create\
tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\
linelist ::punk::lib::linelist\
linesort ::punk::lib::linesort\
pdict ::punk::lib::pdict\
plist {::punk::lib::pdict -roottype list}\
showlist {::punk::lib::showdict -roottype list}\
showdict ::punk::lib::showdict\
ansistrip ::punk::ansi::ansistrip\
stripansi ::punk::ansi::ansistrip\
ansiwrap ::punk::ansi::ansiwrap\
colour ::punk::console::colour\
ansi ::punk::console::ansi\
color ::punk::console::colour\
a+ ::punk::console::code_a+\
A+ {::punk::console::code_a+ forcecolour}\
a ::punk::console::code_a\
A {::punk::console::code_a forcecolour}\
a? ::punk::console::code_a?\
A? {::punk::console::code_a? forcecolor}\
smcup ::punk::console::enable_alt_screen\
rmcup ::punk::console::disable_alt_screen\
]
#*** !doctools
#[subsection {Namespace punk::aliascore}]
#[para] Core API functions for punk::aliascore
#[list_begin definitions]
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[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"
#}
#todo - options as to whether we should raise an error if collisions found, undo aliases etc?
proc init {args} {
set defaults {-force 0}
set opts [dict merge $defaults $args]
set opt_force [dict get $opts -force]
variable aliases
if {!$opt_force} {
set existing [list]
set conflicts [list]
foreach {a cmd} $aliases {
if {[tcl::info::commands ::$a] ne ""} {
lappend existing $a
if {[llength $cmd] > 1} {
#use alias mechanism
set existing_target [interp alias "" $a]
} else {
#using namespace import
#check origin
set existing_target [tcl::namespace::origin $cmd]
}
if {$existing_target ne $cmd} {
#command exists in global ns but doesn't match our defined aliases/imports
lappend conflicts $a
}
}
}
if {[llength $conflicts]} {
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts"
}
}
set tempns ::temp_[info cmdcount] ;#temp ns for renames
dict for {a cmd} $aliases {
#puts "aliascore $a -> $cmd"
if {[llength $cmd] > 1} {
interp alias {} $a {} {*}$cmd
} else {
if {[tcl::info::commands $cmd] ne ""} {
#todo - ensure exported? noclobber?
if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} {
#puts stderr "importing $cmd"
tcl::namespace::eval :: [list namespace import $cmd]
} else {
#target command name differs from exported name
#e.g stripansi -> punk::ansi::ansistrip
#import and rename
#puts stderr "importing $cmd (with rename to ::$a)"
tcl::namespace::eval $tempns [list namespace import $cmd]
catch {rename ${tempns}::[namespace tail $cmd] ::$a}
}
} else {
interp alias {} $a {} {*}$cmd
}
}
}
#tcl::namespace::delete $tempns
return [dict keys $aliases]
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::aliascore ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#interp alias {} list_as_lines {} punk::lib::list_as_lines
#interp alias {} lines_as_list {} punk::lib::lines_as_list
#interp alias {} ansistrip {} punk::ansi::ansistrip ;#review
#interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features
#interp alias {} linesort {} punk::lib::linesort
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::aliascore::lib {
namespace export {[a-z]*} ;# Convention: export all lowercase
namespace path [namespace parent]
#*** !doctools
#[subsection {Namespace punk::aliascore::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::aliascore::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
namespace eval punk::aliascore::system {
#*** !doctools
#[subsection {Namespace punk::aliascore::system}]
#[para] Internal functions that are not part of the API
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::aliascore [namespace eval punk::aliascore {
variable pkg punk::aliascore
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

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

@ -0,0 +1,475 @@
tcl::namespace::eval punk::config {
variable loaded
variable startup ;#include env overrides
variable running
variable punk_env_vars
variable other_env_vars
variable vars
namespace export {[a-z]*}
#todo - XDG_DATA_HOME etc
#https://specifications.freedesktop.org/basedir-spec/latest/
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/
proc init {} {
variable defaults
variable startup
variable running
variable punk_env_vars
variable punk_env_vars_config
variable other_env_vars
variable other_env_vars_config
set exename ""
catch {
#catch for safe interps
#safe base will return empty string, ordinary safe interp will raise error
set exename [tcl::info::nameofexecutable]
}
if {$exename ne ""} {
set exefolder [file dirname $exename]
#default file logs to logs folder at same level as exe if writable, or empty string
set log_folder [file normalize $exefolder/../logs]
#tcl::dict::set startup scriptlib $exefolder/scriptlib
#tcl::dict::set startup apps $exefolder/../../punkapps
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc
set default_scriptlib $exefolder/scriptlib
set default_apps $exefolder/../../punkapps
if {[file isdirectory $log_folder] && [file writable $log_folder]} {
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt
set default_logfile_stdout $log_folder/repl-exec-stdout.txt
set default_logfile_stderr $log_folder/repl-exec-stderr.txt
} else {
set default_logfile_stdout ""
set default_logfile_stderr ""
}
} else {
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island
#review - todo?
#tcl::dict::set startup scriptlib ""
#tcl::dict::set startup apps ""
set default_scriptlib ""
set default_apps ""
set default_logfile_stdout ""
set default_logfile_stderr ""
}
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run
#optional channel transforms on stdout/stderr.
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands
#If no distinction necessary - should use default_color_<chan>
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation.
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc)
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful.
#set default_color_stderr "red bold"
#set default_color_stderr "web-lightsalmon"
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive
set default_color_stderr_repl "" ;#during repl call only
set homedir ""
if {[catch {
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp
set homedir [file home]
} errM]} {
#tcl 8.6 doesn't have file home.. try again
if {[info exists ::env(HOME)]} {
set homedir $::env(HOME)
}
}
# per user xdg vars
# ---
set default_xdg_config_home "" ;#config data - portable
set default_xdg_data_home "" ;#data the user likely to want to be portable
set default_xdg_cache_home "" ;#local cache
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home
# ---
set default_xdg_data_dirs "" ;#non-user specific
#xdg_config_dirs ?
#xdg_runtime_dir ?
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent)
#(safe interp generally won't have access to ::env either)
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent.
if {$homedir ne ""} {
if {"windows" eq $::tcl_platform(platform)} {
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them.
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment)
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do.
if {[info exists ::env(APPDATA)]} {
set default_xdg_config_home $::env(APPDATA)
set default_xdg_data_home $::env(APPDATA)
}
#The xdg_cache_home should be kept local
if {[info exists ::env(LOCALAPPDATA)]} {
set default_xdg_cache_home $::env(LOCALAPPDATA)
set default_xdg_state_home $::env(LOCALAPPDATA)
}
if {[info exists ::env(PROGRAMDATA)]} {
#- equiv env(ALLUSERSPROFILE) ?
set default_xdg_data_dirs $::env(PROGRAMDATA)
}
} else {
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html
set default_xdg_config_home [file join $homedir .config]
set default_xdg_data_home [file join $homedir .local share]
set default_xdg_cache_home [file join $homedir .cache]
set default_xdg_state_home [file join $homedir .local state]
set default_xdg_data_dirs /usr/local/share
}
}
set defaults [dict create\
apps $default_apps\
config ""\
configset ".punkshell"\
scriptlib $default_scriptlib\
color_stdout $default_color_stdout\
color_stdout_repl $default_color_stdout_repl\
color_stderr $default_color_stderr\
color_stderr_repl $default_color_stderr_repl\
logfile_stdout $default_logfile_stdout\
logfile_stderr $default_logfile_stderr\
logfile_active 0\
syslog_stdout "127.0.0.1:514"\
syslog_stderr "127.0.0.1:514"\
syslog_active 0\
auto_exec_mechanism exec\
auto_noexec 0\
xdg_config_home $default_xdg_config_home\
xdg_data_home $default_xdg_data_home\
xdg_cache_home $default_xdg_cache_home\
xdg_state_home $default_xdg_state_home\
xdg_data_dirs $default_xdg_data_dirs\
theme_posh_override ""\
posh_theme ""\
posh_themes_path ""\
]
set startup $defaults
#load values from saved config file - $xdg_config_home/punk/punk.config ?
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines.
#that's possibly ok for the PUNK_ vars
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config?
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence?
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden
#- requiring user to manually unset any unwanted env vars when launching?
#we are likely to want the saved configs for subshells/decks to override them however.
#todo - load/save config file
#todo - define which configvars are settable in env
#list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean)
set punk_env_vars_config [dict create \
PUNK_APPS {type pathlist}\
PUNK_CONFIG {type string}\
PUNK_CONFIGSET {type string}\
PUNK_SCRIPTLIB {type string}\
PUNK_AUTO_EXEC_MECHANISM {type string}\
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\
PUNK_LOGFILE_STDOUT {type string}\
PUNK_LOGFILE_STDERR {type string}\
PUNK_LOGFILE_ACTIVE {type string}\
PUNK_SYSLOG_STDOUT {type string}\
PUNK_SYSLOG_STDERR {type string}\
PUNK_SYSLOG_ACTIVE {type string}\
PUNK_THEME_POSH_OVERRIDE {type string}\
]
set punk_env_vars [dict keys $punk_env_vars_config]
#override with env vars if set
foreach {evar varinfo} $punk_env_vars_config {
if {[info exists ::env($evar)]} {
set vartype [dict get $varinfo type]
set f [set ::env($evar)]
if {$f ne "default"} {
#e.g PUNK_SCRIPTLIB -> scriptlib
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]]
if {$vartype eq "pathlist"} {
#colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system
#Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief.
#For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately.
#some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched.
#An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting
# - but some programs have been known to split this value on colon anyway, which breaks things on windows.
set paths [split $f $::tcl_platform(pathSeparator)]
set final [list]
#eliminate empty values (leading or trailing or extraneous separators)
foreach p $paths {
if {[tcl::string::trim $p] ne ""} {
lappend final $p
}
}
tcl::dict::set startup $varname $final
} else {
tcl::dict::set startup $varname $f
}
}
}
}
# https://no-color.org
#if {[info exists ::env(NO_COLOR)]} {
# if {$::env(NO_COLOR) ne ""} {
# set colour_disabled 1
# }
#}
set other_env_vars_config [dict create\
NO_COLOR {type string}\
XDG_CONFIG_HOME {type string}\
XDG_DATA_HOME {type string}\
XDG_CACHE_HOME {type string}\
XDG_STATE_HOME {type string}\
XDG_DATA_DIRS {type pathlist}\
POSH_THEME {type string}\
POSH_THEMES_PATH {type string}\
TCLLIBPATH {type string}\
]
lassign [split [info tclversion] .] tclmajorv tclminorv
#don't rely on lseq or punk::lib for now..
set relevant_minors [list]
for {set i 0} {$i <= $tclminorv} {incr i} {
lappend relevant_minors $i
}
foreach minor $relevant_minors {
set vname TCL${tclmajorv}_${minor}_TM_PATH
if {$minor eq $tclminorv || [info exists ::env($vname)]} {
dict set other_env_vars_config $vname {type string}
}
}
set other_env_vars [dict keys $other_env_vars_config]
foreach {evar varinfo} $other_env_vars_config {
if {[info exists ::env($evar)]} {
set vartype [dict get $varinfo type]
set f [set ::env($evar)]
if {$f ne "default"} {
set varname [tcl::string::tolower $evar]
if {$vartype eq "pathlist"} {
set paths [split $f $::tcl_platform(pathSeparator)]
set final [list]
#eliminate empty values (leading or trailing or extraneous separators)
foreach p $paths {
if {[tcl::string::trim $p] ne ""} {
lappend final $p
}
}
tcl::dict::set startup $varname $final
} else {
tcl::dict::set startup $varname $f
}
}
}
}
#unset -nocomplain vars
#todo
set running [tcl::dict::create]
set running [tcl::dict::merge $running $startup]
}
init
#todo
proc Apply {config} {
puts stderr "punk::config::Apply partially implemented"
set configname [string map {-config ""} $config]
if {$configname in {startup running}} {
upvar ::punk::config::$configname applyconfig
if {[dict exists $applyconfig auto_noexec]} {
set auto [dict get $applyconfig auto_noexec]
if {![string is boolean -strict $auto]} {
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean"
}
if {$auto} {
set ::auto_noexec 1
} else {
#puts "auto_noexec false"
unset -nocomplain ::auto_noexec
}
}
} else {
error "no config named '$config' found"
}
return "apply done"
}
Apply startup
#todo - consider how to divide up settings, categories, 'devices', decks etc
proc get_running_global {varname} {
variable running
if {[dict exists $running $varname]} {
return [dict get $running $varname]
}
error "No such global configuration item '$varname' found in running config"
}
proc get_startup_global {varname} {
variable startup
if {[dict exists $startup $varname]} {
return [dict get $startup $varname]
}
error "No such global configuration item '$varname' found in startup config"
}
proc get {whichconfig {globfor *}} {
variable startup
variable running
switch -- $whichconfig {
config - startup - startup-config - startup-configuration {
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs
set configdata $startup
}
running - running-config - running-configuration {
set configdata $running
}
default {
error "Unknown config name '$whichconfig' - try startup or running"
}
}
if {$globfor eq "*"} {
return $configdata
} else {
set keys [dict keys $configdata [string tolower $globfor]]
set filtered [dict create]
foreach k $keys {
dict set filtered $k [dict get $configdata $k]
}
return $filtered
}
}
proc configure {args} {
set argd [punk::args::get_dict {
whichconfig -type string -choices {startup running}
} $args]
}
proc show {whichconfig {globfor *}} {
#todo - tables for console
set configdata [punk::config::get $whichconfig $globfor]
return [punk::lib::showdict $configdata]
}
#e.g
# copy running-config startup-config
# copy startup-config test-config.cfg
# copy backup-config.cfg running-config
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite
#This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration
proc copy {args} {
set argd [punk::args::get_dict {
*proc -name punk::config::copy -help "Copy a partial or full configuration from one config to another
If a target config has additional settings, then the source config can be considered to be partial with regards to the target.
"
-type -default "" -choices {replace merge} -help "Defaults to merge when target is running-config
Defaults to replace when source is running-config"
*values -min 2 -max 2
fromconfig -help "running or startup or file name (not fully implemented)"
toconfig -help "running or startup or file name (not fully implemented)"
} $args]
set fromconfig [dict get $argd values fromconfig]
set toconfig [dict get $argd values toconfig]
set fromconfig [string map {-config ""} $fromconfig]
set toconfig [string map {-config ""} $toconfig]
set copytype [dict get $argd opts -type]
#todo - warn & prompt if doing merge copy to startup
switch -exact -- $fromconfig-$toconfig {
running-startup {
if {$copytype eq ""} {
set copytype replace ;#full configuration
}
if {$copytype eq "replace"} {
error "punk::config::copy error. full configuration copy from running to startup config not yet supported"
} else {
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported"
}
}
startup-running {
#default type merge - even though it's not always what is desired
if {$copytype eq ""} {
set copytype merge ;#load in a partial configuration
}
#warn/prompt either way
if {$copytype eq "replace"} {
#some routers require use of a separate command for this branch.
#presumably to ensure the user doesn't accidentally load partials onto a running system
#
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported"
} else {
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported"
}
}
default {
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported"
}
}
}
}
#todo - move to cli?
::tcl::namespace::eval punk::config {
#todo - something better - 'previous' rather than reverting to startup
proc channelcolors {{onoff {}}} {
variable running
variable startup
if {![string length $onoff]} {
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]]
} else {
if {![string is boolean $onoff]} {
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no"
}
if {$onoff} {
dict set running color_stdout [dict get $startup color_stdout]
dict set running color_stderr [dict get $startup color_stderr]
} else {
dict set running color_stdout ""
dict set running color_stderr ""
}
}
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]]
}
}
package provide punk::config [tcl::namespace::eval punk::config {
variable version
set version 0.1
}]

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

@ -0,0 +1,164 @@
#punkapps app manager
# deck cli
namespace eval punk::mod::cli {
namespace export help list run
namespace ensemble create
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown
if 0 {
proc _unknown {ns args} {
puts stderr "punk::mod::cli::_unknown '$ns' '$args'"
puts stderr "punk::mod::cli::help $args"
puts stderr "arglen:[llength $args]"
punk::mod::cli::help {*}$args
}
}
#cli must have _init method - usually used to load commandsets lazily
#
variable initialised 0
proc _init {args} {
variable initialised
if {$initialised} {
return
}
#...
set initialised 1
}
proc help {args} {
set basehelp [punk::mix::base help {*}$args]
#namespace export
return $basehelp
}
proc getraw {appname} {
upvar ::punk::config::running running_config
set app_folders [dict get $running_config apps]
#todo search each app folder
set bases [::list]
set versions [::list]
set mains [::list]
set appinfo [::list bases {} mains {} versions {}]
foreach containerfolder $app_folders {
lappend bases $containerfolder
if {[file exists $containerfolder]} {
if {[file exists $containerfolder/$appname/main.tcl]} {
#exact match - only return info for the exact one specified
set namematches $appname
set parts [split $appname -]
} else {
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*]
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort?
}
foreach nm $namematches {
set mainfile $containerfolder/$nm/main.tcl
set parts [split $nm -]
if {[llength $parts] == 1} {
set ver ""
} else {
set ver [lindex $parts end]
}
if {$ver ni $versions} {
lappend versions $ver
lappend mains $ver $mainfile
} else {
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)"
}
}
} else {
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config"
}
}
dict set appinfo versions $versions
#todo - natsort!
set sorted_versions [lsort $versions]
set latest [lindex $sorted_versions 0]
if {$latest eq "" && [llength $sorted_versions] > 1} {
set latest [lindex $sorted_versions 1
}
dict set appinfo latest $latest
dict set appinfo bases $bases
dict set appinfo mains $mains
return $appinfo
}
proc list {{glob *}} {
upvar ::punk::config::running running_config
set apps_folder [dict get $running_config apps]
if {[file exists $apps_folder]} {
if {[file exists $apps_folder/$glob]} {
#tailcall source $apps_folder/$glob/main.tcl
return $glob
}
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob]
if {[llength $apps] == 0} {
if {[string first * $glob] <0 && [string first ? $glob] <0} {
#no glob chars supplied - only launch if exact match for name part
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*]
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort?
if {[llength $namematches] > 0} {
set latest [lindex $namematches end]
lassign $latest nm ver
#tailcall source $apps_folder/$latest/main.tcl
}
}
}
return $apps
}
}
#todo - way to launch as separate process
# solo-opts only before appname - args following appname are passed to the app
proc run {args} {
set nameposn [lsearch -not $args -*]
if {$nameposn < 0} {
error "punkapp::run unable to determine application name"
}
set appname [lindex $args $nameposn]
set controlargs [lrange $args 0 $nameposn-1]
set appargs [lrange $args $nameposn+1 end]
set appinfo [punk::mod::cli::getraw $appname]
if {[llength [dict get $appinfo versions]]} {
set ver [dict get $appinfo latest]
puts stdout "info: $appinfo"
set ::argc [llength $appargs]
set ::argv $appargs
source [dict get $appinfo mains $ver]
if {"-hideconsole" in $controlargs} {
puts stderr "attempting console hide"
#todo - something better - a callback when window mapped?
after 500 {::punkapp::hide_console}
}
return $appinfo
} else {
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]"
}
}
}
namespace eval punk::mod::cli {
proc _cli {args} {
#don't use tailcall - base uses info level to determine caller
::punk::mix::base::_cli {*}$args
}
variable default_command help
package require punk::mix::base
package require punk::overlay
punk::overlay::custom_from_base [namespace current] ::punk::mix::base
}
package provide punk::mod [namespace eval punk::mod {
variable version
set version 0.1
}]

1373
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm

File diff suppressed because it is too large Load Diff

259
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm

@ -0,0 +1,259 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application punk::repl::codethread 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require punk::repl::codethread]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::repl::codethread
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::repl::codethread
#[list_begin itemized]
package require Tcl 8.6-
package require punk::config
#*** !doctools
#[item] [package {Tcl 8.6}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::repl::codethread::class {
#*** !doctools
#[subsection {Namespace punk::repl::codethread::class}]
#[para] class definitions
#if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::repl::codethread {
tcl::namespace::export *
variable replthread
variable replthread_cond
variable running 0
variable output_stdout ""
variable output_stderr ""
#variable xyz
#*** !doctools
#[subsection {Namespace punk::repl::codethread}]
#[para] Core API functions for punk::repl::codethread
#[list_begin definitions]
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[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"
#}
proc is_running {} {
variable running
return $running
}
proc runscript {script} {
#puts stderr "->runscript"
variable replthread_cond
variable output_stdout ""
variable output_stderr ""
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available
#if a thread::send is done from the commandline in a codethread - Tcl will
if {"code" ni [interp children] || ![info exists replthread_cond]} {
#in case someone tries calling from codethread directly - don't do anything or change any state
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful)
#if called directly - the context will be within the first 'code' interp.
#inappropriate caller could add superfluous entries to shellfilter stack if function errors out
#inappropriate caller could affect tsv vars (if their interp allows that anyway)
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread"
return
}
set outstack [list]
set errstack [list]
upvar ::punk::config::running running_config
if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} {
lappend outstack [interp eval code [list shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]]
}
lappend outstack [interp eval code [list shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]]
if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} {
lappend errstack [interp eval code [list shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]]
# #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]]
}
lappend errstack [interp eval code [list shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]]
#an experiment
#set errhandle [shellfilter::stack::item_tophandle stderr]
#interp transfer "" $errhandle code
set scope [interp eval code [list set ::punk::ns::ns_current]]
set status [catch {
interp eval code [list tcl::namespace::inscope $scope $script]
} result]
flush stdout
flush stderr
#interp transfer code $errhandle ""
#flush $errhandle
set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end]
set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end]
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]"
set tid [thread::id]
tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar]
tsv::set codethread_$tid status $status
tsv::set codethread_$tid result $result
tsv::set codethread_$tid errorcode $::errorCode
#only remove from shellfilter::stack the items we added to stack in this function
foreach s [lreverse $outstack] {
interp eval code [list shellfilter::stack::remove stdout $s]
}
foreach s [lreverse $errstack] {
interp eval code [list shellfilter::stack::remove stderr $s]
}
thread::cond notify $replthread_cond
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::repl::codethread::lib {
tcl::namespace::export *
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::repl::codethread::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::repl::codethread::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
tcl::namespace::eval punk::repl::codethread::system {
#*** !doctools
#[subsection {Namespace punk::repl::codethread::system}]
#[para] Internal functions that are not part of the API
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread {
variable pkg punk::repl::codethread
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

237
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/unixywindows-0.1.0.tm

@ -0,0 +1,237 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application punk::unixywindows 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
#for illegalname_test
package require punk::winpath
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::unixywindows {
#'cached' name to make obvious it could be out of date - and to distinguish from unixyroot arg
variable cachedunixyroot ""
#-----------------
#e.g something like c:/Users/geek/scoop/apps/msys2/current c:/msys2
proc get_unixyroot {} {
variable cachedunixyroot
if {![string length $cachedunixyroot]} {
if {![catch {
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context.
set cachedunixyroot [punk::objclone $result]
file pathtype $cachedunixyroot; #this call causes the int-rep to be path
#set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display
} errM]} {
} else {
puts stderr "Warning: Failed to determine base for unix-like paths - using default of c:/msys2"
file pathtype [set cachedunixyroot [punk::objclone "c:/msys2"]]
}
}
#will have been shimmered from string to 'path' internal rep by 'file pathtype' call
#let's return a different copy as it's so easy to lose path-rep
set copy [punk::objclone $cachedunixyroot]
return $copy
}
proc refresh_unixyroot {} {
variable cachedunixyroot
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context.
set cachedunixyroot [punk::objclone $result]
file pathtype $cachedunixyroot; #this call causes the int-rep to be path
set copy [punk::objclone $cachedunixyroot]
return $copy
}
proc set_unixyroot {windows_path} {
variable cachedunixyroot
file pathtype $windows_path
set cachedunixyroot [punk::objclone $windows_path]
#return the original - but probably int-rep will have shimmered to path even if started out as string
#- that's probably what we want. Caller can use as string or path without affecting cachedunixyroot
return $windows_path
}
proc windir {path} {
if {$path eq "~"} {
#as the tilde hasn't been normalized.. we can't assume we're running on the actual platform
return ~/..
}
return [file dirname [towinpath $path]]
}
#REVIEW high-coupling
proc cdwin {path} {
set path [towinpath $path]
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
if {[llength [info commands ::punk::console::titleset]]} {
::punk::console::titleset $path
}
}
cd $path
}
proc cdwindir {path} {
set path [towinpath $path]
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
if {[llength [info commands ::punk::console::titleset]]} {
::punk::console::titleset $path
}
}
cd [file dirname $path]
}
#NOTE - this is an expensive operation - avoid where possible.
#review - is this intended to be useful/callable on non-windows platforms?
#it should in theory be useable from another platform that wants to create a path for use on windows.
#In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid)
#review zipfs:// other uri schemes?
proc towinpath {unixypath {unixyroot ""}} {
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative)
#(Tcl is also somewhat broken as at 2023 as far as volume relative paths - process can get out of sync with tcl if cd to a vol relative path is used)
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD.
#e.g there is potential confusion when there is a c folder on c: drive (c:/c)
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd.
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong..
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume.
#
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways.
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common
#
#convert /c/etc to C:/etc
set re_slash_x_slash {^/([[:alpha:]]){1}/.*}
set re_slash_else {^/([[:alpha:]]*)(.*)}
set volumes [file volumes]
#exclude things like //zipfs:/ ??
set driveletters [list]
foreach v $volumes {
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} {
lappend driveletters $letter
}
}
#puts stderr "->$driveletters"
set path [punk::objclone $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument
set supplied_pathtype [file pathtype $path] ;#we don't care about the pathtype so much as the act of making this call shimmers to a path internal-rep
#copy of var that we can treat as a string without affecting path rep
#Note that some but not all read operations will lose path rep e.g 'string length $x' will lose any path-rep $x had, (but 'string equal $x something' won't)
#Todo - make int-rep tests to check stability of these behaviours across Tcl versions!
set strcopy_path [punk::objclone $path]
set str_newpath ""
set have_pathobj 0
if {[regexp $re_slash_x_slash $strcopy_path _ letter]} {
#upper case appears to be windows canonical form
set str_newpath [string toupper $letter]:/[string range $strcopy_path 3 end]
} elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $strcopy_path] _ letter]} {
set str_newpath [string toupper $letter]:/[string range $strcopy_path 7 end]
} elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $strcopy_path] _ letter]} {
set str_newpath [string toupper $letter]:/
} elseif {[regexp $re_slash_else $strcopy_path _ firstpart remainder]} {
#could be for example /c or /something/users
if {[string length $firstpart] == 1} {
set letter $firstpart
set str_newpath [string toupper $letter]:/
} else {
#according to regex we have a single leading slash
set str_tail [string range $strcopy_path 1 end]
if {$unixyroot eq ""} {
set unixyroot [get_unixyroot]
} else {
file pathtype $unixyroot; #side-effect generates int-rep of type path )
}
set pathobj [file join $unixyroot $str_tail]
file pathtype $pathobj
set have_pathobj 1
}
}
if {!$have_pathobj} {
if {$str_newpath eq ""} {
#dunno - pass through
set pathobj $path
} else {
set pathobj [punk::objclone $str_newpath]
file pathtype $pathobj
}
}
#puts stderr "=> $path"
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder
#
#By now file normalize shouldn't do too many shannanigans related to cwd..
#We want it to look at cwd for relative paths..
#but we don't consider things like /c/Users to be relative even on windows where it would normally mean a volume-relative path e.g c:/c/Users if cwd happens to be somewhere on C: at the time.
#if {![file exists [file dirname $path]]} {
# set path [file normalize $path]
# #may still not exist.. that's ok.
#}
#file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name
#2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes
if {[punk::winpath::illegalname_test $pathobj]} {
set pathobj [punk::winpath::illegalname_fix $pathobj]
}
return $pathobj
}
#----------------------------------------------
#leave the unixywindows related aliases available on all platforms
#interp alias {} cdwin {} punk::unixywindows::cdwin
#interp alias {} cdwindir {} punk::unixywindoes::cdwindir
#interp alias {} towinpath {} punk::unixywindows::towinpath
#interp alias {} windir {} punk::unixywindows::windir
#----------------------------------------------
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::unixywindows [namespace eval punk::unixywindows {
variable version
set version 0.1.0
}]
return

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

@ -0,0 +1,239 @@
#utilities for punk apps to call
package provide punkapp [namespace eval punkapp {
variable version
set version 0.1
}]
namespace eval punkapp {
variable result
variable waiting "no"
proc hide_dot_window {} {
#alternative to wm withdraw .
#see https://wiki.tcl-lang.org/page/wm+withdraw
wm geometry . 1x1+0+0
wm overrideredirect . 1
wm transient .
}
proc is_toplevel {w} {
if {![llength [info commands winfo]]} {
return 0
}
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]}
}
proc get_toplevels {{w .}} {
if {![llength [info commands winfo]]} {
return [list]
}
set list {}
if {[is_toplevel $w]} {
lappend list $w
}
foreach w [winfo children $w] {
lappend list {*}[get_toplevels $w]
}
return $list
}
proc make_toplevel_next {prefix} {
set top [get_toplevel_next $prefix]
return [toplevel $top]
}
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase?
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix
proc get_toplevel_next {prefix} {
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> ""
}
proc exit {{toplevel ""}} {
variable waiting
variable result
variable default_result
set toplevels [get_toplevels]
if {[string length $toplevel]} {
set wposn [lsearch $toplevels $toplevel]
if {$wposn > 0} {
destroy $toplevel
}
} else {
#review
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
puts stderr "punkapp::exit called without toplevel - showing console"
show_console
return 0
} else {
puts stderr "punkapp::exit called without toplevel - exiting"
if {$waiting ne "no"} {
if {[info exists result(shell)]} {
set temp [set result(shell)]
unset result(shell)
set waiting $temp
} else {
set waiting ""
}
} else {
::exit
}
}
}
set controllable [get_user_controllable_toplevels]
if {![llength $controllable]} {
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
show_console
} else {
if {$waiting ne "no"} {
if {[info exists result(shell)]} {
set temp [set result(shell)]
unset result(shell)
set waiting $temp
} elseif {[info exists result($toplevel)]} {
set temp [set result($toplevel)]
unset result($toplevel)
set waiting $temp
} elseif {[info exists default_result]} {
set temp $default_result
unset default_result
set waiting $temp
} else {
set waiting ""
}
} else {
::exit
}
}
}
}
proc close_window {toplevel} {
wm withdraw $toplevel
if {![llength [get_user_controllable_toplevels]]} {
punkapp::exit $toplevel
}
destroy $toplevel
}
proc wait {args} {
variable waiting
variable default_result
if {[dict exists $args -defaultresult]} {
set default_result [dict get $args -defaultresult]
}
foreach t [punkapp::get_toplevels] {
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} {
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t]
}
}
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
puts stderr "repl eventloop seems to be running - punkapp::wait not required"
} else {
if {$waiting eq "no"} {
set waiting "waiting"
vwait ::punkapp::waiting
return $::punkapp::waiting
}
}
}
#A window can be 'visible' according to this - but underneath other windows etc
#REVIEW - change name?
proc get_visible_toplevels {{w .}} {
if {![llength [info commands winfo]]} {
return [list]
}
set list [get_toplevels $w]
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}]
set mapped [concat {*}$mapped] ;#ignore {}
set visible [list]
foreach m $mapped {
if {[wm overrideredirect $m] == 0 } {
lappend visible $m
} else {
if {[winfo height $m] >1 && [winfo width $m] > 1} {
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible
lappend visible $m
}
}
}
return $visible
}
proc get_user_controllable_toplevels {{w .}} {
set visible [get_visible_toplevels $w]
set controllable [list]
foreach v $visible {
if {[wm overrideredirect $v] == 0} {
lappend controllable $v
}
}
#only return visible windows with overrideredirect == 0 because there exists some user control.
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily
return $controllable
}
proc hide_console {args} {
set opts [dict create -force 0]
if {([llength $args] % 2) != 0} {
error "hide_console expects pairs of arguments. e.g -force 1"
}
#set known_opts [dict keys $defaults]
foreach {k v} $args {
switch -- $k {
-force {
dict set opts $k $v
}
default {
error "Unrecognised options '$k' known options: [dict keys $opts]"
}
}
}
set force [dict get $opts -force]
if {!$force} {
if {![llength [get_user_controllable_toplevels]]} {
puts stderr "Cannot hide console while no user-controllable windows available"
return 0
}
}
if {$::tcl_platform(platform) eq "windows"} {
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway.
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way.
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though.
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call)
package require twapi
set h [twapi::get_console_window]
set pid [twapi::get_window_process $h]
set pinfo [twapi::get_process_info $pid -name]
set pname [dict get $pinfo -name]
set wstyle [twapi::get_window_style $h]
#tclkitsh/tclsh?
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} {
twapi::hide_window $h
return 1
} else {
puts stderr "punkapp::hide_console unable to hide this type of console window"
return 0
}
} else {
#todo
puts stderr "punkapp::hide_console unimplemented on this platform (todo)"
return 0
}
}
proc show_console {} {
if {$::tcl_platform(platform) eq "windows"} {
package require twapi
if {![catch {set h [twapi::get_console_window]} errM]} {
twapi::show_window $h -activate -normal
} else {
#no console - assume launched from something like wish?
catch {console show}
}
} else {
#todo
puts stderr "punkapp::show_console unimplemented on this platform"
}
}
}

333
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm

@ -0,0 +1,333 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application punkcheck::cli 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
package require punk::mix::util
namespace eval punkcheck::cli {
namespace ensemble create
#package require punk::overlay
#punk::overlay::import_commandset debug. ::punk:mix::commandset::debug
#init proc required - used for lazy loading of commandsets
variable initialised 0
proc _init {args} {
variable initialised
if {$initialised} {
return
}
puts stderr "punkcheck::cli::init $args"
set initialised 1
}
proc help {args} {
set basehelp [punk::mix::base help {*}$args]
return $basehelp
}
proc paths {{path {}}} {
if {$path eq {}} { set path [pwd] }
set search_from $path
set bottom_to_top [list]
while {[string length [set pcheck_file [punkcheck::cli::lib::find_nearest_file $search_from]]]} {
set pcheck_folder [file dirname $pcheck_file]
lappend bottom_to_top $pcheck_file
set search_from [file dirname $pcheck_folder]
}
return $bottom_to_top
}
#todo! - group by fileset
proc status {{path {}}} {
if {$path eq {}} { set path [pwd] }
set fullpath [file normalize $path]
set ftype [file type $fullpath]
set files [list]
if {$ftype eq "file"} {
set container [file dirname $fullpath]
lappend files $fullpath
} else {
set container $fullpath
#vfs can mask mounted files - so we can't just use 'file type' or glob with -type f
##set files [glob -nocomplain -dir $fullpath -type f *]
package require punk::nav::fs
set folderinfo [punk::nav::fs::dirfiles_dict $fullpath]
set files [concat [dict get $folderinfo files] [dict get $folderinfo underlayfiles]]
}
set punkcheck_files [paths $container]
set repodict [punk::repo::find_repo $container]
if {![llength $punkcheck_files]} {
puts stderr "No .punkcheck files found at or above this folder"
}
set table ""
set files_with_records [list]
foreach p $punkcheck_files {
set basedir [file dirname $p]
set recordlist [punkcheck::load_records_from_file $p]
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist]
foreach f $files {
set relpath [punkcheck::lib::path_relative $basedir $f]
if {[dict exists $tgt_dict $relpath]} {
set filerec [dict get $tgt_dict $relpath]
set records [punkcheck::dict_getwithdefault $filerec body [list]]
if {$ftype eq "file"} {
if {![llength $records]} {
set pcheck "(has file record but no installation entries)"
} else {
set pcheck \n
foreach irec $records {
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n
#append pcheck " $irec" \n
}
}
} else {
if {![llength $records]} {
set pcheck "(has file record but no installation entries)"
} else {
set display_records [list]
set pcheck \n
set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec]
if {[llength $latest_install_record]} {
lappend display_records $latest_install_record
}
if {$latest_install_record ne [lindex $records end]} {
lappend display_records [lindex $records end]
}
foreach irec $display_records {
append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]"
set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]]
set source_files [list]
set source_files_changed [list]
set source_folders [list]
set source_folders_changed [list]
foreach r $bodyrecords {
if {[dict get $r tag] eq "SOURCE"} {
set path [dict get $r -path]
set changed [dict get $r -changed]
switch -- [dict get $r -type] {
file {
lappend source_files $path
if {$changed} {
lappend source_files_changed $path
}
}
directory {
lappend source_folders $path
if {$changed} {
lappend source_folders_changed $path
}
}
}
}
}
if {[llength $source_files]} {
append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])"
}
if {[llength $source_folders]} {
append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])"
}
append pcheck \n
#append pcheck [punk::tdl::prettyprint [list $irec] 1] \n
#append pcheck " $irec" \n
}
}
}
append table "$f $pcheck" \n
}
}
}
return $table
}
proc status_by_file {{path {}}} {
if {$path eq {}} { set path [pwd] }
set fullpath [file normalize $path]
set ftype [file type $fullpath]
set files [list]
if {$ftype eq "file"} {
set container [file dirname $fullpath]
lappend files $fullpath
} else {
set container $fullpath
set files [glob -nocomplain -dir $fullpath -type f *]
}
set punkcheck_files [paths $container]
set repodict [punk::repo::find_repo $container]
if {![llength $punkcheck_files]} {
puts stderr "No .punkcheck files found at or above this folder"
}
set table ""
set files_with_records [list]
foreach p $punkcheck_files {
set basedir [file dirname $p]
set recordlist [punkcheck::load_records_from_file $p]
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist]
foreach f $files {
set relpath [punkcheck::lib::path_relative $basedir $f]
if {[dict exists $tgt_dict $relpath]} {
set filerec [dict get $tgt_dict $relpath]
set records [punkcheck::dict_getwithdefault $filerec body [list]]
if {$ftype eq "file"} {
if {![llength $records]} {
set pcheck "(has file record but no installation entries)"
} else {
set pcheck \n
foreach irec $records {
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n
#append pcheck " $irec" \n
}
}
} else {
if {![llength $records]} {
set pcheck "(has file record but no installation entries)"
} else {
set display_records [list]
set pcheck \n
set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec]
lappend display_records $latest_install_record
if {$latest_install_record ne [lindex $records end]} {
lappend display_records [lindex $records end]
}
foreach irec $display_records {
append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]"
set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]]
set source_files [list]
set source_files_changed [list]
set source_folders [list]
set source_folders_changed [list]
foreach r $bodyrecords {
if {[dict get $r tag] eq "SOURCE"} {
set path [dict get $r -path]
set changed [dict get $r -changed]
switch -- [dict get $r -type] {
file {
lappend source_files $path
if {$changed} {
lappend source_files_changed $path
}
}
directory {
lappend source_folders $path
if {$changed} {
lappend source_folders_changed $path
}
}
}
}
}
if {[llength $source_files]} {
append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])"
}
if {[llength $source_folders]} {
append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])"
}
append pcheck \n
#append pcheck [punk::tdl::prettyprint [list $irec] 1] \n
#append pcheck " $irec" \n
}
}
}
append table "$f $pcheck" \n
}
}
}
return $table
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punkcheck::cli::lib {
namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc
proc find_nearest_file {{path {}}} {
if {$path eq {}} { set path [pwd] }
set folder [lib::scanup $path lib::is_punkchecked_folder]
if {$folder eq ""} {
return ""
} else {
return [file join $folder .punkcheck]
}
}
proc is_punkchecked_folder {{path {}}} {
if {$path eq {}} { set path [pwd] }
foreach control {
.punkcheck
} {
set control [file join $path $control]
if {[file isfile $control]} {return 1}
}
return 0
}
proc scanup {path cmd} {
if {$path eq {}} { set path [pwd] }
#based on kettle::path::scanup
if {[file pathtype $path] eq "relative"} {
set path [file normalize $path]
}
while {1} {
# Found the proper directory, per the predicate.
if {[{*}$cmd $path]} { return $path }
# Not found, walk to parent
set new [file dirname $path]
# Stop when reaching the root.
if {$new eq $path} { return {} }
if {$new eq {}} { return {} }
# Ok, truly walk up.
set path $new
}
return {}
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punkcheck::cli {
proc _cli {args} {
#don't use tailcall - base uses info level to determine caller
::punk::mix::base::_cli {*}$args
}
variable default_command status
package require punk::mix::base
package require punk::overlay
punk::overlay::custom_from_base [namespace current] ::punk::mix::base
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punkcheck::cli [namespace eval punkcheck::cli {
variable version
set version 0.1.0
}]
return

3078
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm

File diff suppressed because it is too large Load Diff

259
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/argp-0.2.tm

@ -0,0 +1,259 @@
# Tcl parser for optional arguments in function calls and
# commandline arguments
#
# (c) 2001 Bastien Chevreux
# Index of exported commands
# - argp::registerArgs
# - argp::setArgDefaults
# - argp::setArgsNeeded
# - argp::parseArgs
# Internal commands
# - argp::CheckValues
# See end of file for an example on how to use
package provide argp 0.2
namespace eval argp {
variable Optstore
variable Opttypes {
boolean integer double string
}
namespace export {[a-z]*}
}
proc argp::registerArgs { func arglist } {
variable Opttypes
variable Optstore
set parentns [string range [uplevel 1 [list namespace current]] 2 end]
if { $parentns != "" } {
append caller $parentns :: $func
} else {
set caller $func
}
set cmangled [string map {:: _} $caller]
#puts $parentns
#puts $caller
#puts $cmangled
set Optstore(keys,$cmangled) {}
set Optstore(deflist,$cmangled) {}
set Optstore(argneeded,$cmangled) {}
foreach arg $arglist {
foreach {opt type default allowed} $arg {
set optindex [lsearch -glob $Opttypes $type*]
if { $optindex < 0} {
return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]"
}
set type [lindex $Opttypes $optindex]
lappend Optstore(keys,$cmangled) $opt
set Optstore(type,$opt,$cmangled) $type
set Optstore(default,$opt,$cmangled) $default
set Optstore(allowed,$opt,$cmangled) $allowed
lappend Optstore(deflist,$cmangled) $opt $default
}
}
if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} {
return -code error "Error in declaration of optional arguments.\n$res"
}
}
proc argp::setArgDefaults { func arglist } {
variable Optstore
set parentns [string range [uplevel 1 [list namespace current]] 2 end]
if { $parentns != "" } {
append caller $parentns :: $func
} else {
set caller $func
}
set cmangled [string map {:: _} $caller]
if {![info exists Optstore(deflist,$cmangled)]} {
return -code error "Arguments for $caller not registered yet."
}
set Optstore(deflist,$cmangled) {}
foreach {opt default} $arglist {
if {![info exists Optstore(default,$opt,$cmangled)]} {
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)"
}
set Optstore(default,$opt,$cmangled) $default
}
# set the new defaultlist
foreach opt $Optstore(keys,$cmangled) {
lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled)
}
}
proc argp::setArgsNeeded { func arglist } {
variable Optstore
set parentns [string range [uplevel 1 [list namespace current]] 2 end]
if { $parentns != "" } {
append caller $parentns :: $func
} else {
set caller $func
}
set cmangled [string map {:: _} $caller]
#append caller $parentns :: $func
#set cmangled ${parentns}_$func
if {![info exists Optstore(deflist,$cmangled)]} {
return -code error "Arguments for $caller not registered yet."
}
set Optstore(argneeded,$cmangled) {}
foreach opt $arglist {
if {![info exists Optstore(default,$opt,$cmangled)]} {
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)"
}
lappend Optstore(argneeded,$cmangled) $opt
}
}
proc argp::parseArgs { args } {
variable Optstore
if {[llength $args] == 0} {
upvar args a opts o
} else {
upvar args a [lindex $args 0] o
}
if { [ catch { set caller [lindex [info level -1] 0]}]} {
set caller "main program"
set cmangled ""
} else {
set cmangled [string map {:: _} $caller]
}
if {![info exists Optstore(deflist,$cmangled)]} {
return -code error "Arguments for $caller not registered yet."
}
# set the defaults
array set o $Optstore(deflist,$cmangled)
# but unset the needed arguments
foreach key $Optstore(argneeded,$cmangled) {
catch { unset o($key) }
}
foreach {key val} $a {
if {![info exists Optstore(type,$key,$cmangled)]} {
return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)"
}
switch -exact -- $Optstore(type,$key,$cmangled) {
boolean -
integer {
if { $val == "" } {
return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value."
}
if { ![string is $Optstore(type,$key,$cmangled) $val]} {
return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value."
}
}
double {
if { $val == "" } {
return -code error "$caller, $key empty string is not double value."
}
if { ![string is double $val]} {
return -code error "$caller, $key $val is not double value."
}
if { [string is integer $val]} {
set val [expr {$val + .0}]
}
}
default {
}
}
set o($key) $val
}
foreach key $Optstore(argneeded,$cmangled) {
if {![info exists o($key)]} {
return -code error "$caller, needed argument $key was not given."
}
}
if { [catch { CheckValues $caller $cmangled [array get o]} err]} {
return -code error $err
}
return
}
proc argp::CheckValues { caller cmangled checklist } {
variable Optstore
#puts "Checking $checklist"
foreach {key val} $checklist {
if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } {
switch -exact -- $Optstore(type,$key,$cmangled) {
string {
if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} {
return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)"
}
}
double -
integer {
set found 0
foreach range $Optstore(allowed,$key,$cmangled) {
if {[llength $range] == 1} {
if { $val == [lindex $range 0] } {
set found 1
break
}
} elseif {[llength $range] == 2} {
set low [lindex $range 0]
set high [lindex $range 1]
if { ![string is integer $low] \
&& [string compare "-" $low] != 0} {
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not \u00b4-\u00b4: $range"
}
if { ![string is integer $high] \
&& [string compare "+" $high] != 0} {
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not \u00b4+\u00b4: $range"
}
if {[string compare "-" $low] == 0} {
if { [string compare "+" $high] == 0 \
|| $val <= $high } {
set found 1
break
}
}
if { $val >= $low } {
if {[string compare "+" $high] == 0 \
|| $val <= $high } {
set found 1
break
}
}
} else {
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range"
}
}
if { $found == 0 } {
return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)"
}
}
}
}
}
}

306
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/debug-1.0.6.tm

@ -0,0 +1,306 @@
# Debug - a debug narrative logger.
# -- Colin McCormack / originally Wub server utilities
#
# Debugging areas of interest are represented by 'tokens' which have
# independantly settable levels of interest (an integer, higher is more detailed)
#
# Debug narrative is provided as a tcl script whose value is [subst]ed in the
# caller's scope if and only if the current level of interest matches or exceeds
# the Debug call's level of detail. This is useful, as one can place arbitrarily
# complex narrative in code without unnecessarily evaluating it.
#
# TODO: potentially different streams for different areas of interest.
# (currently only stderr is used. there is some complexity in efficient
# cross-threaded streams.)
# # ## ### ##### ######## ############# #####################
## Requisites
package require Tcl 8.5-
namespace eval ::debug {
namespace export -clear \
define on off prefix suffix header trailer \
names 2array level setting parray pdict \
nl tab hexl
namespace ensemble create -subcommands {}
}
# # ## ### ##### ######## ############# #####################
## API & Implementation
proc ::debug::noop {args} {}
proc ::debug::debug {tag message {level 1}} {
variable detail
if {$detail($tag) < $level} {
#puts stderr "$tag @@@ $detail($tag) >= $level"
return
}
variable prefix
variable suffix
variable header
variable trailer
variable fds
if {[info exists fds($tag)]} {
set fd $fds($tag)
} else {
set fd stderr
}
# Assemble the shown text from the user message and the various
# prefixes and suffices (global + per-tag).
set themessage ""
if {[info exists prefix(::)]} { append themessage $prefix(::) }
if {[info exists prefix($tag)]} { append themessage $prefix($tag) }
append themessage $message
if {[info exists suffix($tag)]} { append themessage $suffix($tag) }
if {[info exists suffix(::)]} { append themessage $suffix(::) }
# Resolve variables references and command invokations embedded
# into the message with plain text.
set code [catch {
set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]]
set sheader [uplevel 1 [list ::subst -nobackslashes $header]]
set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]]
} __ eo]
# And dump an internal error if that resolution failed.
if {$code} {
if {[catch {
set caller [info level -1]
}]} { set caller GLOBAL }
if {[string length $caller] >= 1000} {
set caller "[string range $caller 0 200]...[string range $caller end-200 end]"
}
foreach line [split $caller \n] {
puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)"
}
return
}
# From here we have a good message to show. We only shorten it a
# bit if its a bit excessive in size.
if {[string length $smessage] > 4096} {
set head [string range $smessage 0 2048]
set tail [string range $smessage end-2048 end]
set smessage "${head}...(truncated)...$tail"
}
foreach line [split $smessage \n] {
puts $fd "$sheader$tag | $line$strailer"
}
return
}
# names - return names of debug tags
proc ::debug::names {} {
variable detail
return [lsort [array names detail]]
}
proc ::debug::2array {} {
variable detail
set result {}
foreach n [lsort [array names detail]] {
if {[interp alias {} debug.$n] ne "::debug::noop"} {
lappend result $n $detail($n)
} else {
lappend result $n -$detail($n)
}
}
return $result
}
# level - set level and fd for tag
proc ::debug::level {tag {level ""} {fd {}}} {
variable detail
# TODO: Force level >=0.
if {$level ne ""} {
set detail($tag) $level
}
if {![info exists detail($tag)]} {
set detail($tag) 1
}
variable fds
if {$fd ne {}} {
set fds($tag) $fd
}
return $detail($tag)
}
proc ::debug::header {text} { variable header $text }
proc ::debug::trailer {text} { variable trailer $text }
proc ::debug::define {tag} {
if {[interp alias {} debug.$tag] ne {}} return
off $tag
return
}
# Set a prefix/suffix to use for tag.
# The global (tag-independent) prefix/suffix is adressed through tag '::'.
# This works because colon (:) is an illegal character for user-specified tags.
proc ::debug::prefix {tag {theprefix {}}} {
variable prefix
set prefix($tag) $theprefix
if {[interp alias {} debug.$tag] ne {}} return
off $tag
return
}
proc ::debug::suffix {tag {theprefix {}}} {
variable suffix
set suffix($tag) $theprefix
if {[interp alias {} debug.$tag] ne {}} return
off $tag
return
}
# turn on debugging for tag
proc ::debug::on {tag {level ""} {fd {}}} {
variable active
set active($tag) 1
level $tag $level $fd
interp alias {} debug.$tag {} ::debug::debug $tag
return
}
# turn off debugging for tag
proc ::debug::off {tag {level ""} {fd {}}} {
variable active
set active($tag) 1
level $tag $level $fd
interp alias {} debug.$tag {} ::debug::noop
return
}
proc ::debug::setting {args} {
if {[llength $args] == 1} {
set args [lindex $args 0]
}
set fd stderr
if {[llength $args] % 2} {
set fd [lindex $args end]
set args [lrange $args 0 end-1]
}
foreach {tag level} $args {
if {$level > 0} {
level $tag $level $fd
interp alias {} debug.$tag {} ::debug::debug $tag
} else {
level $tag [expr {-$level}] $fd
interp alias {} debug.$tag {} ::debug::noop
}
}
return
}
# # ## ### ##### ######## ############# #####################
## Convenience commands.
# Format arrays and dicts as multi-line message.
# Insert newlines and tabs.
proc ::debug::nl {} { return \n }
proc ::debug::tab {} { return \t }
proc ::debug::parray {a {pattern *}} {
upvar 1 $a array
if {![array exists array]} {
error "\"$a\" isn't an array"
}
pdict [array get array] $pattern
}
proc ::debug::pdict {dict {pattern *}} {
set maxl 0
set names [lsort -dict [dict keys $dict $pattern]]
foreach name $names {
if {[string length $name] > $maxl} {
set maxl [string length $name]
}
}
set maxl [expr {$maxl + 2}]
set lines {}
foreach name $names {
set nameString [format (%s) $name]
lappend lines [format "%-*s = %s" \
$maxl $nameString \
[dict get $dict $name]]
}
return [join $lines \n]
}
proc ::debug::hexl {data {prefix {}}} {
set r {}
# Convert the data to hex and to characters.
binary scan $data H*@0a* hexa asciia
# Replace non-printing characters in the data with dots.
regsub -all -- {[^[:graph:] ]} $asciia {.} asciia
# Pad with spaces to a full multiple of 32/16.
set n [expr {[string length $hexa] % 32}]
if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] }
#puts "pad H [expr {32-$n}]"
set n [expr {[string length $asciia] % 32}]
if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] }
#puts "pad A [expr {32-$n}]"
# Reassemble formatted, in groups of 16 bytes/characters.
# The hex part is handled in groups of 32 nibbles.
set addr 0
while {[string length $hexa]} {
# Get front group of 16 bytes each.
set hex [string range $hexa 0 31]
set ascii [string range $asciia 0 15]
# Prep for next iteration
set hexa [string range $hexa 32 end]
set asciia [string range $asciia 16 end]
# Convert the hex to pairs of hex digits
regsub -all -- {..} $hex {& } hex
# Add the hex and latin-1 data to the result buffer
append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n
incr addr 16
}
# And done
return $r
}
# # ## ### ##### ######## ############# #####################
namespace eval debug {
variable detail ; # map: TAG -> level of interest
variable prefix ; # map: TAG -> message prefix to use
variable suffix ; # map: TAG -> message suffix to use
variable fds ; # map: TAG -> handle of open channel to log to.
variable header {} ; # per-line heading, subst'ed
variable trailer {} ; # per-line ending, subst'ed
# Notes:
# - The tag '::' is reserved. "prefix" and "suffix" use it to store
# the global message prefix / suffix.
# - prefix and suffix are applied per message.
# - header and trailer are per line. And should not generate multiple lines!
}
# # ## ### ##### ######## ############# #####################
## Ready
package provide debug 1.0.6
return

2714
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/flagfilter-0.3.tm

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,322 @@
package provide funcl [namespace eval funcl {
variable version
set version 0.1
}]
#funcl = function list (nested call structure)
#
#a basic functional composition o combinator
#o(f,g)(x) == f(g(x))
namespace eval funcl {
#from punk
proc arg_is_script_shaped {arg} {
if {[string first " " $arg] >= 0} {
return 1
} elseif {[string first \n $arg] >= 0} {
return 1
} elseif {[string first ";" $arg] >= 0} {
return 1
} elseif {[string first \t $arg] >= 0} {
return 1
} else {
return 0
}
}
proc o args {
set closing [string repeat {]} [expr [llength $args]-1]]
set body "[join $args { [}] \$data $closing"
return $body
}
proc o_ args {
set body ""
set tails [lrepeat [llength $args] ""]
puts stdout "tails: $tails"
set end [lindex $args end]
if {[llength $end] == 1 && [arg_is_script_shaped $end]} {
set endfunc [string map "<end> $end" {uplevel 1 [list if 1 <end> ]}]
} else {
set endfunc $end
}
if {[llength $args] == 1} {
return $endfunc
}
set wrap { [}
append wrap $endfunc
append wrap { ]}
set i 0
foreach cmdlist [lrange $args 0 end-1] {
set is_script 0
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} {
set is_script 1
set script [lindex $cmdlist 0]
}
set t ""
if {$i > 0} {
append body { [}
}
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
if {$i == [expr {[llength $args] -2}]} {
#append body " \$data"
append body " $wrap"
}
if {$i > 0} {
set t {]}
}
} else {
append body [lrange $cmdlist 0 $posn-1]
if {$i == [expr {[llength $args] -2}]} {
#append body " \$data"
append body " $wrap"
}
set t [lrange $cmdlist $posn+1 end]
if {$i > 0} {
append t { ]}
}
}
lset tails $i $t
incr i
}
append body [join [lreverse $tails] " "]
puts stdout "tails: $tails"
return $body
}
#review - consider _call -- if count > 1 then they must all be callable cmdlists(?)
# what does it mean to have additional _fn wrapper with no other elements? (no actual function)
#e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}}
# what type indicates running subtrees in parallel vs sequentially?
# any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc.
#
#
# accept or return a funcl (or funcltree if multiple funcls in one commandlist)
# also accept/return a call - return empty list if passed a call
proc next_funcl {funcl_or_tree} {
if {[lindex $funcl_or_tree 0] eq "_call"} {
return [list]
}
if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} {
set funcl $funcl_or_tree
} else {
error "funcltree not implemented"
}
set count [lindex $funcl 1]
if {$count == 0} {
#null funcl.. what is it? metadata/placeholder?
return $funcl
}
set indices [lrange $funcl 2 [expr {1 + $count}]]
set i 0
foreach idx $indices {
if {$i > 0} {
#todo - return a funcltree
error "multi funcl not implemented"
}
set next [lindex $funcl $idx]
incr i
}
return $next
}
#convert a funcl to a tcl script
proc funcl_script {funcl} {
if {![llength $funcl]} {
return ""
}
set body ""
set tails [list]
set type [lindex $funcl 0]
if {$type ni [list "_fn" "_call"]} {
#todo - handle funcltree
error "type $type not implemented"
}
#only count of 1 with index 3 supported(?)
if {$type eq "_call"} {
#leaf
set cmdlist [lindex $funcl 3]
return $cmdlist
}
#we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times.
#by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?)
# we would still need to maintain state to stitch it back together once returned from a subtree..
# ie multiple tail parts
set count [lindex $funcl 1]
if {$count == 1} {
set idx [lindex $funcl 2]
if {$idx == 3} {
set cmdlist_pre [list]
} else {
set cmdlist_pre [lrange $funcl 3 $idx-1]
}
append body $cmdlist_pre
set t [lrange $funcl $idx+1 end]
lappend tails $t
} else {
#??
error "funcl_script branching not yet supported"
}
set get_next 1
set i 1
while {$get_next} {
set funcl [next_funcl $funcl]
if {![llength $funcl]} {
set get_next 0
}
lassign $funcl type count idx ;#todo support count > 1
if {$type eq "_call"} {
set get_next 0
}
set t ""
if {$type eq "_call"} {
append body { [}
append body [lindex $funcl $idx]
append body { ]}
} else {
append body { [}
if {$idx == 3} {
set cmdlist_pre [list]
} else {
set cmdlist_pre [lrange $funcl 3 $idx-1]
}
append body $cmdlist_pre
set t [lrange $funcl $idx+1 end]
lappend tails $t
lappend tails { ]}
}
incr i
}
append body [join [lreverse $tails] " "]
#puts stdout "tails: $tails"
return $body
}
interp alias "" o_of "" funcl::o_of_n 1
#o_of_n
#tcl list rep o combinator
#
# can take lists of ordinary commandlists, scripts and funcls
# _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg)
# _fn 0 indicates next item is an unwrapped commandlist (terminal command)
#
#o_of is equivalent to o_of_n 1 (1 argument o combinator)
#last n args are passed to the prior function
#e.g for n=1 f a b = f(a(b))
#e.g for n=2, e f a b = e(f(a b))
proc o_of_n {n args} {
puts stdout "o_of_n '$args'"
if {$n != 1} {
error "o_of_n only implemented for 1 sub-funcl"
}
set comp [list] ;#composition list
set end [lindex $args end]
if {[lindex $end 0] in {_fn _call}]} {
#is_funcl
set endfunc [lindex $args end]
} else {
if {[llength $end] == 1 && [arg_is_script_shaped $end]} {
#set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}]
set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]]
} else {
set endfunc [list _call 1 3 [list {*}$end]]
}
}
if {[llength $args] == 1} {
return $endfunc
}
set comp $endfunc
set revlist [lreverse [lrange $args 0 end-1]]
foreach cmdlist $revlist {
puts stderr "o_of_n >>-- $cmdlist"
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} {
set is_script 1
set script [lindex $cmdlist 0]
set arglist [list data]
set comp [list _fn 1 6 call_script $script $arglist $comp]
} else {
set posn1 [expr {[llength $cmdlist] + 2 + $n}]
set comp [list _fn $n $posn1 {*}$cmdlist $comp]
}
}
return $comp
}
proc call_script {script argnames args} {
uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]]
}
proc funcl_script_test {scr} {
do_funcl_script_test $scr
}
proc do_funcl_script_test {scr} {
#set j "in do_funcl_script_test"
#set data "xxx"
#puts '$scr'
if 1 $scr
}
#standard o_ with no script-handling
proc o_plain args {
set body ""
set i 0
set tails [lrepeat [llength $args] ""]
#puts stdout "tails: $tails"
foreach cmdlist $args {
set t ""
if {$i > 0} {
append body { [}
}
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
if {$i == [expr {[llength $args] -1}]} {
append body " \$data"
}
if {$i > 0} {
set t {]}
}
} else {
append body [lrange $cmdlist 0 $posn-1]
if {$i == [expr {[llength $args] -1}]} {
append body " \$data"
}
set t [lrange $cmdlist $posn+1 end]
if {$i > 0} {
append t { ]}
}
}
lset tails $i $t
incr i
}
append body [join [lreverse $tails] " "]
#puts stdout "tails: $tails"
return $body
}
#timings suggest no faster to split out the first item from the cmdlist loop
}

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

@ -2,18 +2,29 @@
#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project #bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project
#They must be already built, so generally shouldn't come directly from src/modules. #They must be already built, so generally shouldn't come directly from src/modules.
#we want showdict - but it needs punk pipeline notation.
#this requires pulling in punk - which brings in lots of other stuff
#The original idea was that bootsupport could be a subset - but in practice we seem to need pretty much everything?
#we still get the advantage that the bootsupport modules can be updated independently (less frequently - after testing)
#each entry - base module #each entry - base module
set bootsupport_modules [list\ set bootsupport_modules [list\
src/vendormodules commandstack\ src/vendormodules commandstack\
src/vendormodules cksum\ src/vendormodules cksum\
src/vendormodules debug\
src/vendormodules dictutils\ src/vendormodules dictutils\
src/vendormodules fauxlink\ src/vendormodules fauxlink\
src/vendormodules fileutil\ src/vendormodules fileutil\
src/vendormodules http\ src/vendormodules http\
src/vendormodules md5\ src/vendormodules md5\
src/vendormodules metaface\
src/vendormodules modpod\ src/vendormodules modpod\
src/vendormodules oolib\ src/vendormodules oolib\
src/vendormodules overtype\ src/vendormodules overtype\
src/vendormodules pattern\
src/vendormodules patterncmd\
src/vendormodules patternlib\
src/vendormodules patternpredator2\
src/vendormodules sha1\ src/vendormodules sha1\
src/vendormodules tomlish\ src/vendormodules tomlish\
src/vendormodules test::tomlish\ src/vendormodules test::tomlish\
@ -25,8 +36,15 @@ set bootsupport_modules [list\
src/vendormodules textutil::trim\ src/vendormodules textutil::trim\
src/vendormodules textutil::wcswidth\ src/vendormodules textutil::wcswidth\
src/vendormodules uuid\ src/vendormodules uuid\
modules punkcheck\ modules argp\
modules flagfilter\
modules funcl\
modules natsort\ modules natsort\
modules punk\
modules punkapp\
modules punkcheck\
modules punkcheck::cli\
modules punk::aliascore\
modules punk::ansi\ modules punk::ansi\
modules punk::assertion\ modules punk::assertion\
modules punk::args\ modules punk::args\
@ -35,6 +53,7 @@ set bootsupport_modules [list\
modules punk::cap::handlers::scriptlibs\ modules punk::cap::handlers::scriptlibs\
modules punk::cap::handlers::templates\ modules punk::cap::handlers::templates\
modules punk::char\ modules punk::char\
modules punk::config\
modules punk::console\ modules punk::console\
modules punk::du\ modules punk::du\
modules punk::encmime\ modules punk::encmime\
@ -46,6 +65,7 @@ set bootsupport_modules [list\
modules punk::mix::cli\ modules punk::mix::cli\
modules punk::mix::util\ modules punk::mix::util\
modules punk::mix::templates\ modules punk::mix::templates\
modules punk::repl::codethread\
modules punk::mix::commandset::buildsuite\ modules punk::mix::commandset::buildsuite\
modules punk::mix::commandset::debug\ modules punk::mix::commandset::debug\
modules punk::mix::commandset::doc\ modules punk::mix::commandset::doc\
@ -55,14 +75,18 @@ set bootsupport_modules [list\
modules punk::mix::commandset::project\ modules punk::mix::commandset::project\
modules punk::mix::commandset::repo\ modules punk::mix::commandset::repo\
modules punk::mix::commandset::scriptwrap\ modules punk::mix::commandset::scriptwrap\
modules punk::mod\
modules punk::nav::fs\
modules punk::ns\ modules punk::ns\
modules punk::overlay\ modules punk::overlay\
modules punk::path\ modules punk::path\
modules punk::packagepreference\ modules punk::packagepreference\
modules punk::repo\ modules punk::repo\
modules punk::tdl\ modules punk::tdl\
modules punk::unixywindows\
modules punk::zip\ modules punk::zip\
modules punk::winpath\ modules punk::winpath\
modules shellfilter\
modules textblock\ modules textblock\
modules natsort\ modules natsort\
modules oolib\ modules oolib\

6411
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/metaface-1.2.5.tm

File diff suppressed because it is too large Load Diff

1285
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/pattern-1.2.4.tm

File diff suppressed because it is too large Load Diff

645
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm

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

2590
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patternlib-1.2.6.tm

File diff suppressed because it is too large Load Diff

754
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm

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

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

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,272 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application punk::aliascore 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::aliascore 0 0.1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require punk::aliascore]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::aliascore
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::aliascore
#[list_begin itemized]
package require Tcl 8.6-
#*** !doctools
#[item] [package {Tcl 8.6}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::aliascore::class {
# #*** !doctools
# #[subsection {Namespace punk::aliascore::class}]
# #[para] class definitions
# if {[info commands [namespace current]::interface_sample1] eq ""} {
# #*** !doctools
# #[list_begin enumerated]
#
# # oo::class create interface_sample1 {
# # #*** !doctools
# # #[enum] CLASS [class interface_sample1]
# # #[list_begin definitions]
#
# # method test {arg1} {
# # #*** !doctools
# # #[call class::interface_sample1 [method test] [arg arg1]]
# # #[para] test method
# # puts "test: $arg1"
# # }
#
# # #*** !doctools
# # #[list_end] [comment {-- end definitions interface_sample1}]
# # }
#
# #*** !doctools
# #[list_end] [comment {--- end class enumeration ---}]
# }
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::aliascore {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
variable aliases
#use absolute ns ie must be prefixed with ::
#single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased
#functions must be in export list of their source namespace
set aliases [tcl::dict::create\
tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\
linelist ::punk::lib::linelist\
linesort ::punk::lib::linesort\
pdict ::punk::lib::pdict\
plist {::punk::lib::pdict -roottype list}\
showlist {::punk::lib::showdict -roottype list}\
showdict ::punk::lib::showdict\
ansistrip ::punk::ansi::ansistrip\
stripansi ::punk::ansi::ansistrip\
ansiwrap ::punk::ansi::ansiwrap\
colour ::punk::console::colour\
ansi ::punk::console::ansi\
color ::punk::console::colour\
a+ ::punk::console::code_a+\
A+ {::punk::console::code_a+ forcecolour}\
a ::punk::console::code_a\
A {::punk::console::code_a forcecolour}\
a? ::punk::console::code_a?\
A? {::punk::console::code_a? forcecolor}\
smcup ::punk::console::enable_alt_screen\
rmcup ::punk::console::disable_alt_screen\
]
#*** !doctools
#[subsection {Namespace punk::aliascore}]
#[para] Core API functions for punk::aliascore
#[list_begin definitions]
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[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"
#}
#todo - options as to whether we should raise an error if collisions found, undo aliases etc?
proc init {args} {
set defaults {-force 0}
set opts [dict merge $defaults $args]
set opt_force [dict get $opts -force]
variable aliases
if {!$opt_force} {
set existing [list]
set conflicts [list]
foreach {a cmd} $aliases {
if {[tcl::info::commands ::$a] ne ""} {
lappend existing $a
if {[llength $cmd] > 1} {
#use alias mechanism
set existing_target [interp alias "" $a]
} else {
#using namespace import
#check origin
set existing_target [tcl::namespace::origin $cmd]
}
if {$existing_target ne $cmd} {
#command exists in global ns but doesn't match our defined aliases/imports
lappend conflicts $a
}
}
}
if {[llength $conflicts]} {
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts"
}
}
set tempns ::temp_[info cmdcount] ;#temp ns for renames
dict for {a cmd} $aliases {
#puts "aliascore $a -> $cmd"
if {[llength $cmd] > 1} {
interp alias {} $a {} {*}$cmd
} else {
if {[tcl::info::commands $cmd] ne ""} {
#todo - ensure exported? noclobber?
if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} {
#puts stderr "importing $cmd"
tcl::namespace::eval :: [list namespace import $cmd]
} else {
#target command name differs from exported name
#e.g stripansi -> punk::ansi::ansistrip
#import and rename
#puts stderr "importing $cmd (with rename to ::$a)"
tcl::namespace::eval $tempns [list namespace import $cmd]
catch {rename ${tempns}::[namespace tail $cmd] ::$a}
}
} else {
interp alias {} $a {} {*}$cmd
}
}
}
#tcl::namespace::delete $tempns
return [dict keys $aliases]
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::aliascore ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#interp alias {} list_as_lines {} punk::lib::list_as_lines
#interp alias {} lines_as_list {} punk::lib::lines_as_list
#interp alias {} ansistrip {} punk::ansi::ansistrip ;#review
#interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features
#interp alias {} linesort {} punk::lib::linesort
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::aliascore::lib {
namespace export {[a-z]*} ;# Convention: export all lowercase
namespace path [namespace parent]
#*** !doctools
#[subsection {Namespace punk::aliascore::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::aliascore::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
namespace eval punk::aliascore::system {
#*** !doctools
#[subsection {Namespace punk::aliascore::system}]
#[para] Internal functions that are not part of the API
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::aliascore [namespace eval punk::aliascore {
variable pkg punk::aliascore
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

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

@ -0,0 +1,475 @@
tcl::namespace::eval punk::config {
variable loaded
variable startup ;#include env overrides
variable running
variable punk_env_vars
variable other_env_vars
variable vars
namespace export {[a-z]*}
#todo - XDG_DATA_HOME etc
#https://specifications.freedesktop.org/basedir-spec/latest/
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/
proc init {} {
variable defaults
variable startup
variable running
variable punk_env_vars
variable punk_env_vars_config
variable other_env_vars
variable other_env_vars_config
set exename ""
catch {
#catch for safe interps
#safe base will return empty string, ordinary safe interp will raise error
set exename [tcl::info::nameofexecutable]
}
if {$exename ne ""} {
set exefolder [file dirname $exename]
#default file logs to logs folder at same level as exe if writable, or empty string
set log_folder [file normalize $exefolder/../logs]
#tcl::dict::set startup scriptlib $exefolder/scriptlib
#tcl::dict::set startup apps $exefolder/../../punkapps
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc
set default_scriptlib $exefolder/scriptlib
set default_apps $exefolder/../../punkapps
if {[file isdirectory $log_folder] && [file writable $log_folder]} {
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt
set default_logfile_stdout $log_folder/repl-exec-stdout.txt
set default_logfile_stderr $log_folder/repl-exec-stderr.txt
} else {
set default_logfile_stdout ""
set default_logfile_stderr ""
}
} else {
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island
#review - todo?
#tcl::dict::set startup scriptlib ""
#tcl::dict::set startup apps ""
set default_scriptlib ""
set default_apps ""
set default_logfile_stdout ""
set default_logfile_stderr ""
}
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run
#optional channel transforms on stdout/stderr.
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands
#If no distinction necessary - should use default_color_<chan>
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation.
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc)
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful.
#set default_color_stderr "red bold"
#set default_color_stderr "web-lightsalmon"
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive
set default_color_stderr_repl "" ;#during repl call only
set homedir ""
if {[catch {
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp
set homedir [file home]
} errM]} {
#tcl 8.6 doesn't have file home.. try again
if {[info exists ::env(HOME)]} {
set homedir $::env(HOME)
}
}
# per user xdg vars
# ---
set default_xdg_config_home "" ;#config data - portable
set default_xdg_data_home "" ;#data the user likely to want to be portable
set default_xdg_cache_home "" ;#local cache
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home
# ---
set default_xdg_data_dirs "" ;#non-user specific
#xdg_config_dirs ?
#xdg_runtime_dir ?
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent)
#(safe interp generally won't have access to ::env either)
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent.
if {$homedir ne ""} {
if {"windows" eq $::tcl_platform(platform)} {
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them.
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment)
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do.
if {[info exists ::env(APPDATA)]} {
set default_xdg_config_home $::env(APPDATA)
set default_xdg_data_home $::env(APPDATA)
}
#The xdg_cache_home should be kept local
if {[info exists ::env(LOCALAPPDATA)]} {
set default_xdg_cache_home $::env(LOCALAPPDATA)
set default_xdg_state_home $::env(LOCALAPPDATA)
}
if {[info exists ::env(PROGRAMDATA)]} {
#- equiv env(ALLUSERSPROFILE) ?
set default_xdg_data_dirs $::env(PROGRAMDATA)
}
} else {
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html
set default_xdg_config_home [file join $homedir .config]
set default_xdg_data_home [file join $homedir .local share]
set default_xdg_cache_home [file join $homedir .cache]
set default_xdg_state_home [file join $homedir .local state]
set default_xdg_data_dirs /usr/local/share
}
}
set defaults [dict create\
apps $default_apps\
config ""\
configset ".punkshell"\
scriptlib $default_scriptlib\
color_stdout $default_color_stdout\
color_stdout_repl $default_color_stdout_repl\
color_stderr $default_color_stderr\
color_stderr_repl $default_color_stderr_repl\
logfile_stdout $default_logfile_stdout\
logfile_stderr $default_logfile_stderr\
logfile_active 0\
syslog_stdout "127.0.0.1:514"\
syslog_stderr "127.0.0.1:514"\
syslog_active 0\
auto_exec_mechanism exec\
auto_noexec 0\
xdg_config_home $default_xdg_config_home\
xdg_data_home $default_xdg_data_home\
xdg_cache_home $default_xdg_cache_home\
xdg_state_home $default_xdg_state_home\
xdg_data_dirs $default_xdg_data_dirs\
theme_posh_override ""\
posh_theme ""\
posh_themes_path ""\
]
set startup $defaults
#load values from saved config file - $xdg_config_home/punk/punk.config ?
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines.
#that's possibly ok for the PUNK_ vars
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config?
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence?
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden
#- requiring user to manually unset any unwanted env vars when launching?
#we are likely to want the saved configs for subshells/decks to override them however.
#todo - load/save config file
#todo - define which configvars are settable in env
#list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean)
set punk_env_vars_config [dict create \
PUNK_APPS {type pathlist}\
PUNK_CONFIG {type string}\
PUNK_CONFIGSET {type string}\
PUNK_SCRIPTLIB {type string}\
PUNK_AUTO_EXEC_MECHANISM {type string}\
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\
PUNK_LOGFILE_STDOUT {type string}\
PUNK_LOGFILE_STDERR {type string}\
PUNK_LOGFILE_ACTIVE {type string}\
PUNK_SYSLOG_STDOUT {type string}\
PUNK_SYSLOG_STDERR {type string}\
PUNK_SYSLOG_ACTIVE {type string}\
PUNK_THEME_POSH_OVERRIDE {type string}\
]
set punk_env_vars [dict keys $punk_env_vars_config]
#override with env vars if set
foreach {evar varinfo} $punk_env_vars_config {
if {[info exists ::env($evar)]} {
set vartype [dict get $varinfo type]
set f [set ::env($evar)]
if {$f ne "default"} {
#e.g PUNK_SCRIPTLIB -> scriptlib
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]]
if {$vartype eq "pathlist"} {
#colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system
#Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief.
#For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately.
#some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched.
#An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting
# - but some programs have been known to split this value on colon anyway, which breaks things on windows.
set paths [split $f $::tcl_platform(pathSeparator)]
set final [list]
#eliminate empty values (leading or trailing or extraneous separators)
foreach p $paths {
if {[tcl::string::trim $p] ne ""} {
lappend final $p
}
}
tcl::dict::set startup $varname $final
} else {
tcl::dict::set startup $varname $f
}
}
}
}
# https://no-color.org
#if {[info exists ::env(NO_COLOR)]} {
# if {$::env(NO_COLOR) ne ""} {
# set colour_disabled 1
# }
#}
set other_env_vars_config [dict create\
NO_COLOR {type string}\
XDG_CONFIG_HOME {type string}\
XDG_DATA_HOME {type string}\
XDG_CACHE_HOME {type string}\
XDG_STATE_HOME {type string}\
XDG_DATA_DIRS {type pathlist}\
POSH_THEME {type string}\
POSH_THEMES_PATH {type string}\
TCLLIBPATH {type string}\
]
lassign [split [info tclversion] .] tclmajorv tclminorv
#don't rely on lseq or punk::lib for now..
set relevant_minors [list]
for {set i 0} {$i <= $tclminorv} {incr i} {
lappend relevant_minors $i
}
foreach minor $relevant_minors {
set vname TCL${tclmajorv}_${minor}_TM_PATH
if {$minor eq $tclminorv || [info exists ::env($vname)]} {
dict set other_env_vars_config $vname {type string}
}
}
set other_env_vars [dict keys $other_env_vars_config]
foreach {evar varinfo} $other_env_vars_config {
if {[info exists ::env($evar)]} {
set vartype [dict get $varinfo type]
set f [set ::env($evar)]
if {$f ne "default"} {
set varname [tcl::string::tolower $evar]
if {$vartype eq "pathlist"} {
set paths [split $f $::tcl_platform(pathSeparator)]
set final [list]
#eliminate empty values (leading or trailing or extraneous separators)
foreach p $paths {
if {[tcl::string::trim $p] ne ""} {
lappend final $p
}
}
tcl::dict::set startup $varname $final
} else {
tcl::dict::set startup $varname $f
}
}
}
}
#unset -nocomplain vars
#todo
set running [tcl::dict::create]
set running [tcl::dict::merge $running $startup]
}
init
#todo
proc Apply {config} {
puts stderr "punk::config::Apply partially implemented"
set configname [string map {-config ""} $config]
if {$configname in {startup running}} {
upvar ::punk::config::$configname applyconfig
if {[dict exists $applyconfig auto_noexec]} {
set auto [dict get $applyconfig auto_noexec]
if {![string is boolean -strict $auto]} {
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean"
}
if {$auto} {
set ::auto_noexec 1
} else {
#puts "auto_noexec false"
unset -nocomplain ::auto_noexec
}
}
} else {
error "no config named '$config' found"
}
return "apply done"
}
Apply startup
#todo - consider how to divide up settings, categories, 'devices', decks etc
proc get_running_global {varname} {
variable running
if {[dict exists $running $varname]} {
return [dict get $running $varname]
}
error "No such global configuration item '$varname' found in running config"
}
proc get_startup_global {varname} {
variable startup
if {[dict exists $startup $varname]} {
return [dict get $startup $varname]
}
error "No such global configuration item '$varname' found in startup config"
}
proc get {whichconfig {globfor *}} {
variable startup
variable running
switch -- $whichconfig {
config - startup - startup-config - startup-configuration {
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs
set configdata $startup
}
running - running-config - running-configuration {
set configdata $running
}
default {
error "Unknown config name '$whichconfig' - try startup or running"
}
}
if {$globfor eq "*"} {
return $configdata
} else {
set keys [dict keys $configdata [string tolower $globfor]]
set filtered [dict create]
foreach k $keys {
dict set filtered $k [dict get $configdata $k]
}
return $filtered
}
}
proc configure {args} {
set argd [punk::args::get_dict {
whichconfig -type string -choices {startup running}
} $args]
}
proc show {whichconfig {globfor *}} {
#todo - tables for console
set configdata [punk::config::get $whichconfig $globfor]
return [punk::lib::showdict $configdata]
}
#e.g
# copy running-config startup-config
# copy startup-config test-config.cfg
# copy backup-config.cfg running-config
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite
#This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration
proc copy {args} {
set argd [punk::args::get_dict {
*proc -name punk::config::copy -help "Copy a partial or full configuration from one config to another
If a target config has additional settings, then the source config can be considered to be partial with regards to the target.
"
-type -default "" -choices {replace merge} -help "Defaults to merge when target is running-config
Defaults to replace when source is running-config"
*values -min 2 -max 2
fromconfig -help "running or startup or file name (not fully implemented)"
toconfig -help "running or startup or file name (not fully implemented)"
} $args]
set fromconfig [dict get $argd values fromconfig]
set toconfig [dict get $argd values toconfig]
set fromconfig [string map {-config ""} $fromconfig]
set toconfig [string map {-config ""} $toconfig]
set copytype [dict get $argd opts -type]
#todo - warn & prompt if doing merge copy to startup
switch -exact -- $fromconfig-$toconfig {
running-startup {
if {$copytype eq ""} {
set copytype replace ;#full configuration
}
if {$copytype eq "replace"} {
error "punk::config::copy error. full configuration copy from running to startup config not yet supported"
} else {
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported"
}
}
startup-running {
#default type merge - even though it's not always what is desired
if {$copytype eq ""} {
set copytype merge ;#load in a partial configuration
}
#warn/prompt either way
if {$copytype eq "replace"} {
#some routers require use of a separate command for this branch.
#presumably to ensure the user doesn't accidentally load partials onto a running system
#
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported"
} else {
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported"
}
}
default {
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported"
}
}
}
}
#todo - move to cli?
::tcl::namespace::eval punk::config {
#todo - something better - 'previous' rather than reverting to startup
proc channelcolors {{onoff {}}} {
variable running
variable startup
if {![string length $onoff]} {
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]]
} else {
if {![string is boolean $onoff]} {
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no"
}
if {$onoff} {
dict set running color_stdout [dict get $startup color_stdout]
dict set running color_stderr [dict get $startup color_stderr]
} else {
dict set running color_stdout ""
dict set running color_stderr ""
}
}
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]]
}
}
package provide punk::config [tcl::namespace::eval punk::config {
variable version
set version 0.1
}]

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

@ -0,0 +1,164 @@
#punkapps app manager
# deck cli
namespace eval punk::mod::cli {
namespace export help list run
namespace ensemble create
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown
if 0 {
proc _unknown {ns args} {
puts stderr "punk::mod::cli::_unknown '$ns' '$args'"
puts stderr "punk::mod::cli::help $args"
puts stderr "arglen:[llength $args]"
punk::mod::cli::help {*}$args
}
}
#cli must have _init method - usually used to load commandsets lazily
#
variable initialised 0
proc _init {args} {
variable initialised
if {$initialised} {
return
}
#...
set initialised 1
}
proc help {args} {
set basehelp [punk::mix::base help {*}$args]
#namespace export
return $basehelp
}
proc getraw {appname} {
upvar ::punk::config::running running_config
set app_folders [dict get $running_config apps]
#todo search each app folder
set bases [::list]
set versions [::list]
set mains [::list]
set appinfo [::list bases {} mains {} versions {}]
foreach containerfolder $app_folders {
lappend bases $containerfolder
if {[file exists $containerfolder]} {
if {[file exists $containerfolder/$appname/main.tcl]} {
#exact match - only return info for the exact one specified
set namematches $appname
set parts [split $appname -]
} else {
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*]
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort?
}
foreach nm $namematches {
set mainfile $containerfolder/$nm/main.tcl
set parts [split $nm -]
if {[llength $parts] == 1} {
set ver ""
} else {
set ver [lindex $parts end]
}
if {$ver ni $versions} {
lappend versions $ver
lappend mains $ver $mainfile
} else {
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)"
}
}
} else {
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config"
}
}
dict set appinfo versions $versions
#todo - natsort!
set sorted_versions [lsort $versions]
set latest [lindex $sorted_versions 0]
if {$latest eq "" && [llength $sorted_versions] > 1} {
set latest [lindex $sorted_versions 1
}
dict set appinfo latest $latest
dict set appinfo bases $bases
dict set appinfo mains $mains
return $appinfo
}
proc list {{glob *}} {
upvar ::punk::config::running running_config
set apps_folder [dict get $running_config apps]
if {[file exists $apps_folder]} {
if {[file exists $apps_folder/$glob]} {
#tailcall source $apps_folder/$glob/main.tcl
return $glob
}
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob]
if {[llength $apps] == 0} {
if {[string first * $glob] <0 && [string first ? $glob] <0} {
#no glob chars supplied - only launch if exact match for name part
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*]
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort?
if {[llength $namematches] > 0} {
set latest [lindex $namematches end]
lassign $latest nm ver
#tailcall source $apps_folder/$latest/main.tcl
}
}
}
return $apps
}
}
#todo - way to launch as separate process
# solo-opts only before appname - args following appname are passed to the app
proc run {args} {
set nameposn [lsearch -not $args -*]
if {$nameposn < 0} {
error "punkapp::run unable to determine application name"
}
set appname [lindex $args $nameposn]
set controlargs [lrange $args 0 $nameposn-1]
set appargs [lrange $args $nameposn+1 end]
set appinfo [punk::mod::cli::getraw $appname]
if {[llength [dict get $appinfo versions]]} {
set ver [dict get $appinfo latest]
puts stdout "info: $appinfo"
set ::argc [llength $appargs]
set ::argv $appargs
source [dict get $appinfo mains $ver]
if {"-hideconsole" in $controlargs} {
puts stderr "attempting console hide"
#todo - something better - a callback when window mapped?
after 500 {::punkapp::hide_console}
}
return $appinfo
} else {
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]"
}
}
}
namespace eval punk::mod::cli {
proc _cli {args} {
#don't use tailcall - base uses info level to determine caller
::punk::mix::base::_cli {*}$args
}
variable default_command help
package require punk::mix::base
package require punk::overlay
punk::overlay::custom_from_base [namespace current] ::punk::mix::base
}
package provide punk::mod [namespace eval punk::mod {
variable version
set version 0.1
}]

1373
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm

File diff suppressed because it is too large Load Diff

259
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm

@ -0,0 +1,259 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application punk::repl::codethread 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require punk::repl::codethread]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::repl::codethread
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::repl::codethread
#[list_begin itemized]
package require Tcl 8.6-
package require punk::config
#*** !doctools
#[item] [package {Tcl 8.6}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::repl::codethread::class {
#*** !doctools
#[subsection {Namespace punk::repl::codethread::class}]
#[para] class definitions
#if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::repl::codethread {
tcl::namespace::export *
variable replthread
variable replthread_cond
variable running 0
variable output_stdout ""
variable output_stderr ""
#variable xyz
#*** !doctools
#[subsection {Namespace punk::repl::codethread}]
#[para] Core API functions for punk::repl::codethread
#[list_begin definitions]
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[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"
#}
proc is_running {} {
variable running
return $running
}
proc runscript {script} {
#puts stderr "->runscript"
variable replthread_cond
variable output_stdout ""
variable output_stderr ""
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available
#if a thread::send is done from the commandline in a codethread - Tcl will
if {"code" ni [interp children] || ![info exists replthread_cond]} {
#in case someone tries calling from codethread directly - don't do anything or change any state
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful)
#if called directly - the context will be within the first 'code' interp.
#inappropriate caller could add superfluous entries to shellfilter stack if function errors out
#inappropriate caller could affect tsv vars (if their interp allows that anyway)
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread"
return
}
set outstack [list]
set errstack [list]
upvar ::punk::config::running running_config
if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} {
lappend outstack [interp eval code [list shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]]
}
lappend outstack [interp eval code [list shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]]
if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} {
lappend errstack [interp eval code [list shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]]
# #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]]
}
lappend errstack [interp eval code [list shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]]
#an experiment
#set errhandle [shellfilter::stack::item_tophandle stderr]
#interp transfer "" $errhandle code
set scope [interp eval code [list set ::punk::ns::ns_current]]
set status [catch {
interp eval code [list tcl::namespace::inscope $scope $script]
} result]
flush stdout
flush stderr
#interp transfer code $errhandle ""
#flush $errhandle
set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end]
set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end]
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]"
set tid [thread::id]
tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar]
tsv::set codethread_$tid status $status
tsv::set codethread_$tid result $result
tsv::set codethread_$tid errorcode $::errorCode
#only remove from shellfilter::stack the items we added to stack in this function
foreach s [lreverse $outstack] {
interp eval code [list shellfilter::stack::remove stdout $s]
}
foreach s [lreverse $errstack] {
interp eval code [list shellfilter::stack::remove stderr $s]
}
thread::cond notify $replthread_cond
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::repl::codethread::lib {
tcl::namespace::export *
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::repl::codethread::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::repl::codethread::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
tcl::namespace::eval punk::repl::codethread::system {
#*** !doctools
#[subsection {Namespace punk::repl::codethread::system}]
#[para] Internal functions that are not part of the API
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread {
variable pkg punk::repl::codethread
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

237
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/unixywindows-0.1.0.tm

@ -0,0 +1,237 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application punk::unixywindows 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
#for illegalname_test
package require punk::winpath
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::unixywindows {
#'cached' name to make obvious it could be out of date - and to distinguish from unixyroot arg
variable cachedunixyroot ""
#-----------------
#e.g something like c:/Users/geek/scoop/apps/msys2/current c:/msys2
proc get_unixyroot {} {
variable cachedunixyroot
if {![string length $cachedunixyroot]} {
if {![catch {
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context.
set cachedunixyroot [punk::objclone $result]
file pathtype $cachedunixyroot; #this call causes the int-rep to be path
#set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display
} errM]} {
} else {
puts stderr "Warning: Failed to determine base for unix-like paths - using default of c:/msys2"
file pathtype [set cachedunixyroot [punk::objclone "c:/msys2"]]
}
}
#will have been shimmered from string to 'path' internal rep by 'file pathtype' call
#let's return a different copy as it's so easy to lose path-rep
set copy [punk::objclone $cachedunixyroot]
return $copy
}
proc refresh_unixyroot {} {
variable cachedunixyroot
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context.
set cachedunixyroot [punk::objclone $result]
file pathtype $cachedunixyroot; #this call causes the int-rep to be path
set copy [punk::objclone $cachedunixyroot]
return $copy
}
proc set_unixyroot {windows_path} {
variable cachedunixyroot
file pathtype $windows_path
set cachedunixyroot [punk::objclone $windows_path]
#return the original - but probably int-rep will have shimmered to path even if started out as string
#- that's probably what we want. Caller can use as string or path without affecting cachedunixyroot
return $windows_path
}
proc windir {path} {
if {$path eq "~"} {
#as the tilde hasn't been normalized.. we can't assume we're running on the actual platform
return ~/..
}
return [file dirname [towinpath $path]]
}
#REVIEW high-coupling
proc cdwin {path} {
set path [towinpath $path]
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
if {[llength [info commands ::punk::console::titleset]]} {
::punk::console::titleset $path
}
}
cd $path
}
proc cdwindir {path} {
set path [towinpath $path]
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
if {[llength [info commands ::punk::console::titleset]]} {
::punk::console::titleset $path
}
}
cd [file dirname $path]
}
#NOTE - this is an expensive operation - avoid where possible.
#review - is this intended to be useful/callable on non-windows platforms?
#it should in theory be useable from another platform that wants to create a path for use on windows.
#In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid)
#review zipfs:// other uri schemes?
proc towinpath {unixypath {unixyroot ""}} {
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative)
#(Tcl is also somewhat broken as at 2023 as far as volume relative paths - process can get out of sync with tcl if cd to a vol relative path is used)
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD.
#e.g there is potential confusion when there is a c folder on c: drive (c:/c)
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd.
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong..
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume.
#
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways.
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common
#
#convert /c/etc to C:/etc
set re_slash_x_slash {^/([[:alpha:]]){1}/.*}
set re_slash_else {^/([[:alpha:]]*)(.*)}
set volumes [file volumes]
#exclude things like //zipfs:/ ??
set driveletters [list]
foreach v $volumes {
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} {
lappend driveletters $letter
}
}
#puts stderr "->$driveletters"
set path [punk::objclone $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument
set supplied_pathtype [file pathtype $path] ;#we don't care about the pathtype so much as the act of making this call shimmers to a path internal-rep
#copy of var that we can treat as a string without affecting path rep
#Note that some but not all read operations will lose path rep e.g 'string length $x' will lose any path-rep $x had, (but 'string equal $x something' won't)
#Todo - make int-rep tests to check stability of these behaviours across Tcl versions!
set strcopy_path [punk::objclone $path]
set str_newpath ""
set have_pathobj 0
if {[regexp $re_slash_x_slash $strcopy_path _ letter]} {
#upper case appears to be windows canonical form
set str_newpath [string toupper $letter]:/[string range $strcopy_path 3 end]
} elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $strcopy_path] _ letter]} {
set str_newpath [string toupper $letter]:/[string range $strcopy_path 7 end]
} elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $strcopy_path] _ letter]} {
set str_newpath [string toupper $letter]:/
} elseif {[regexp $re_slash_else $strcopy_path _ firstpart remainder]} {
#could be for example /c or /something/users
if {[string length $firstpart] == 1} {
set letter $firstpart
set str_newpath [string toupper $letter]:/
} else {
#according to regex we have a single leading slash
set str_tail [string range $strcopy_path 1 end]
if {$unixyroot eq ""} {
set unixyroot [get_unixyroot]
} else {
file pathtype $unixyroot; #side-effect generates int-rep of type path )
}
set pathobj [file join $unixyroot $str_tail]
file pathtype $pathobj
set have_pathobj 1
}
}
if {!$have_pathobj} {
if {$str_newpath eq ""} {
#dunno - pass through
set pathobj $path
} else {
set pathobj [punk::objclone $str_newpath]
file pathtype $pathobj
}
}
#puts stderr "=> $path"
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder
#
#By now file normalize shouldn't do too many shannanigans related to cwd..
#We want it to look at cwd for relative paths..
#but we don't consider things like /c/Users to be relative even on windows where it would normally mean a volume-relative path e.g c:/c/Users if cwd happens to be somewhere on C: at the time.
#if {![file exists [file dirname $path]]} {
# set path [file normalize $path]
# #may still not exist.. that's ok.
#}
#file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name
#2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes
if {[punk::winpath::illegalname_test $pathobj]} {
set pathobj [punk::winpath::illegalname_fix $pathobj]
}
return $pathobj
}
#----------------------------------------------
#leave the unixywindows related aliases available on all platforms
#interp alias {} cdwin {} punk::unixywindows::cdwin
#interp alias {} cdwindir {} punk::unixywindoes::cdwindir
#interp alias {} towinpath {} punk::unixywindows::towinpath
#interp alias {} windir {} punk::unixywindows::windir
#----------------------------------------------
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::unixywindows [namespace eval punk::unixywindows {
variable version
set version 0.1.0
}]
return

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

@ -0,0 +1,239 @@
#utilities for punk apps to call
package provide punkapp [namespace eval punkapp {
variable version
set version 0.1
}]
namespace eval punkapp {
variable result
variable waiting "no"
proc hide_dot_window {} {
#alternative to wm withdraw .
#see https://wiki.tcl-lang.org/page/wm+withdraw
wm geometry . 1x1+0+0
wm overrideredirect . 1
wm transient .
}
proc is_toplevel {w} {
if {![llength [info commands winfo]]} {
return 0
}
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]}
}
proc get_toplevels {{w .}} {
if {![llength [info commands winfo]]} {
return [list]
}
set list {}
if {[is_toplevel $w]} {
lappend list $w
}
foreach w [winfo children $w] {
lappend list {*}[get_toplevels $w]
}
return $list
}
proc make_toplevel_next {prefix} {
set top [get_toplevel_next $prefix]
return [toplevel $top]
}
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase?
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix
proc get_toplevel_next {prefix} {
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> ""
}
proc exit {{toplevel ""}} {
variable waiting
variable result
variable default_result
set toplevels [get_toplevels]
if {[string length $toplevel]} {
set wposn [lsearch $toplevels $toplevel]
if {$wposn > 0} {
destroy $toplevel
}
} else {
#review
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
puts stderr "punkapp::exit called without toplevel - showing console"
show_console
return 0
} else {
puts stderr "punkapp::exit called without toplevel - exiting"
if {$waiting ne "no"} {
if {[info exists result(shell)]} {
set temp [set result(shell)]
unset result(shell)
set waiting $temp
} else {
set waiting ""
}
} else {
::exit
}
}
}
set controllable [get_user_controllable_toplevels]
if {![llength $controllable]} {
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
show_console
} else {
if {$waiting ne "no"} {
if {[info exists result(shell)]} {
set temp [set result(shell)]
unset result(shell)
set waiting $temp
} elseif {[info exists result($toplevel)]} {
set temp [set result($toplevel)]
unset result($toplevel)
set waiting $temp
} elseif {[info exists default_result]} {
set temp $default_result
unset default_result
set waiting $temp
} else {
set waiting ""
}
} else {
::exit
}
}
}
}
proc close_window {toplevel} {
wm withdraw $toplevel
if {![llength [get_user_controllable_toplevels]]} {
punkapp::exit $toplevel
}
destroy $toplevel
}
proc wait {args} {
variable waiting
variable default_result
if {[dict exists $args -defaultresult]} {
set default_result [dict get $args -defaultresult]
}
foreach t [punkapp::get_toplevels] {
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} {
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t]
}
}
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
puts stderr "repl eventloop seems to be running - punkapp::wait not required"
} else {
if {$waiting eq "no"} {
set waiting "waiting"
vwait ::punkapp::waiting
return $::punkapp::waiting
}
}
}
#A window can be 'visible' according to this - but underneath other windows etc
#REVIEW - change name?
proc get_visible_toplevels {{w .}} {
if {![llength [info commands winfo]]} {
return [list]
}
set list [get_toplevels $w]
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}]
set mapped [concat {*}$mapped] ;#ignore {}
set visible [list]
foreach m $mapped {
if {[wm overrideredirect $m] == 0 } {
lappend visible $m
} else {
if {[winfo height $m] >1 && [winfo width $m] > 1} {
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible
lappend visible $m
}
}
}
return $visible
}
proc get_user_controllable_toplevels {{w .}} {
set visible [get_visible_toplevels $w]
set controllable [list]
foreach v $visible {
if {[wm overrideredirect $v] == 0} {
lappend controllable $v
}
}
#only return visible windows with overrideredirect == 0 because there exists some user control.
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily
return $controllable
}
proc hide_console {args} {
set opts [dict create -force 0]
if {([llength $args] % 2) != 0} {
error "hide_console expects pairs of arguments. e.g -force 1"
}
#set known_opts [dict keys $defaults]
foreach {k v} $args {
switch -- $k {
-force {
dict set opts $k $v
}
default {
error "Unrecognised options '$k' known options: [dict keys $opts]"
}
}
}
set force [dict get $opts -force]
if {!$force} {
if {![llength [get_user_controllable_toplevels]]} {
puts stderr "Cannot hide console while no user-controllable windows available"
return 0
}
}
if {$::tcl_platform(platform) eq "windows"} {
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway.
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way.
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though.
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call)
package require twapi
set h [twapi::get_console_window]
set pid [twapi::get_window_process $h]
set pinfo [twapi::get_process_info $pid -name]
set pname [dict get $pinfo -name]
set wstyle [twapi::get_window_style $h]
#tclkitsh/tclsh?
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} {
twapi::hide_window $h
return 1
} else {
puts stderr "punkapp::hide_console unable to hide this type of console window"
return 0
}
} else {
#todo
puts stderr "punkapp::hide_console unimplemented on this platform (todo)"
return 0
}
}
proc show_console {} {
if {$::tcl_platform(platform) eq "windows"} {
package require twapi
if {![catch {set h [twapi::get_console_window]} errM]} {
twapi::show_window $h -activate -normal
} else {
#no console - assume launched from something like wish?
catch {console show}
}
} else {
#todo
puts stderr "punkapp::show_console unimplemented on this platform"
}
}
}

333
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm

@ -0,0 +1,333 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application punkcheck::cli 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
package require punk::mix::util
namespace eval punkcheck::cli {
namespace ensemble create
#package require punk::overlay
#punk::overlay::import_commandset debug. ::punk:mix::commandset::debug
#init proc required - used for lazy loading of commandsets
variable initialised 0
proc _init {args} {
variable initialised
if {$initialised} {
return
}
puts stderr "punkcheck::cli::init $args"
set initialised 1
}
proc help {args} {
set basehelp [punk::mix::base help {*}$args]
return $basehelp
}
proc paths {{path {}}} {
if {$path eq {}} { set path [pwd] }
set search_from $path
set bottom_to_top [list]
while {[string length [set pcheck_file [punkcheck::cli::lib::find_nearest_file $search_from]]]} {
set pcheck_folder [file dirname $pcheck_file]
lappend bottom_to_top $pcheck_file
set search_from [file dirname $pcheck_folder]
}
return $bottom_to_top
}
#todo! - group by fileset
proc status {{path {}}} {
if {$path eq {}} { set path [pwd] }
set fullpath [file normalize $path]
set ftype [file type $fullpath]
set files [list]
if {$ftype eq "file"} {
set container [file dirname $fullpath]
lappend files $fullpath
} else {
set container $fullpath
#vfs can mask mounted files - so we can't just use 'file type' or glob with -type f
##set files [glob -nocomplain -dir $fullpath -type f *]
package require punk::nav::fs
set folderinfo [punk::nav::fs::dirfiles_dict $fullpath]
set files [concat [dict get $folderinfo files] [dict get $folderinfo underlayfiles]]
}
set punkcheck_files [paths $container]
set repodict [punk::repo::find_repo $container]
if {![llength $punkcheck_files]} {
puts stderr "No .punkcheck files found at or above this folder"
}
set table ""
set files_with_records [list]
foreach p $punkcheck_files {
set basedir [file dirname $p]
set recordlist [punkcheck::load_records_from_file $p]
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist]
foreach f $files {
set relpath [punkcheck::lib::path_relative $basedir $f]
if {[dict exists $tgt_dict $relpath]} {
set filerec [dict get $tgt_dict $relpath]
set records [punkcheck::dict_getwithdefault $filerec body [list]]
if {$ftype eq "file"} {
if {![llength $records]} {
set pcheck "(has file record but no installation entries)"
} else {
set pcheck \n
foreach irec $records {
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n
#append pcheck " $irec" \n
}
}
} else {
if {![llength $records]} {
set pcheck "(has file record but no installation entries)"
} else {
set display_records [list]
set pcheck \n
set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec]
if {[llength $latest_install_record]} {
lappend display_records $latest_install_record
}
if {$latest_install_record ne [lindex $records end]} {
lappend display_records [lindex $records end]
}
foreach irec $display_records {
append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]"
set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]]
set source_files [list]
set source_files_changed [list]
set source_folders [list]
set source_folders_changed [list]
foreach r $bodyrecords {
if {[dict get $r tag] eq "SOURCE"} {
set path [dict get $r -path]
set changed [dict get $r -changed]
switch -- [dict get $r -type] {
file {
lappend source_files $path
if {$changed} {
lappend source_files_changed $path
}
}
directory {
lappend source_folders $path
if {$changed} {
lappend source_folders_changed $path
}
}
}
}
}
if {[llength $source_files]} {
append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])"
}
if {[llength $source_folders]} {
append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])"
}
append pcheck \n
#append pcheck [punk::tdl::prettyprint [list $irec] 1] \n
#append pcheck " $irec" \n
}
}
}
append table "$f $pcheck" \n
}
}
}
return $table
}
proc status_by_file {{path {}}} {
if {$path eq {}} { set path [pwd] }
set fullpath [file normalize $path]
set ftype [file type $fullpath]
set files [list]
if {$ftype eq "file"} {
set container [file dirname $fullpath]
lappend files $fullpath
} else {
set container $fullpath
set files [glob -nocomplain -dir $fullpath -type f *]
}
set punkcheck_files [paths $container]
set repodict [punk::repo::find_repo $container]
if {![llength $punkcheck_files]} {
puts stderr "No .punkcheck files found at or above this folder"
}
set table ""
set files_with_records [list]
foreach p $punkcheck_files {
set basedir [file dirname $p]
set recordlist [punkcheck::load_records_from_file $p]
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist]
foreach f $files {
set relpath [punkcheck::lib::path_relative $basedir $f]
if {[dict exists $tgt_dict $relpath]} {
set filerec [dict get $tgt_dict $relpath]
set records [punkcheck::dict_getwithdefault $filerec body [list]]
if {$ftype eq "file"} {
if {![llength $records]} {
set pcheck "(has file record but no installation entries)"
} else {
set pcheck \n
foreach irec $records {
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n
#append pcheck " $irec" \n
}
}
} else {
if {![llength $records]} {
set pcheck "(has file record but no installation entries)"
} else {
set display_records [list]
set pcheck \n
set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec]
lappend display_records $latest_install_record
if {$latest_install_record ne [lindex $records end]} {
lappend display_records [lindex $records end]
}
foreach irec $display_records {
append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]"
set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]]
set source_files [list]
set source_files_changed [list]
set source_folders [list]
set source_folders_changed [list]
foreach r $bodyrecords {
if {[dict get $r tag] eq "SOURCE"} {
set path [dict get $r -path]
set changed [dict get $r -changed]
switch -- [dict get $r -type] {
file {
lappend source_files $path
if {$changed} {
lappend source_files_changed $path
}
}
directory {
lappend source_folders $path
if {$changed} {
lappend source_folders_changed $path
}
}
}
}
}
if {[llength $source_files]} {
append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])"
}
if {[llength $source_folders]} {
append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])"
}
append pcheck \n
#append pcheck [punk::tdl::prettyprint [list $irec] 1] \n
#append pcheck " $irec" \n
}
}
}
append table "$f $pcheck" \n
}
}
}
return $table
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punkcheck::cli::lib {
namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc
proc find_nearest_file {{path {}}} {
if {$path eq {}} { set path [pwd] }
set folder [lib::scanup $path lib::is_punkchecked_folder]
if {$folder eq ""} {
return ""
} else {
return [file join $folder .punkcheck]
}
}
proc is_punkchecked_folder {{path {}}} {
if {$path eq {}} { set path [pwd] }
foreach control {
.punkcheck
} {
set control [file join $path $control]
if {[file isfile $control]} {return 1}
}
return 0
}
proc scanup {path cmd} {
if {$path eq {}} { set path [pwd] }
#based on kettle::path::scanup
if {[file pathtype $path] eq "relative"} {
set path [file normalize $path]
}
while {1} {
# Found the proper directory, per the predicate.
if {[{*}$cmd $path]} { return $path }
# Not found, walk to parent
set new [file dirname $path]
# Stop when reaching the root.
if {$new eq $path} { return {} }
if {$new eq {}} { return {} }
# Ok, truly walk up.
set path $new
}
return {}
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punkcheck::cli {
proc _cli {args} {
#don't use tailcall - base uses info level to determine caller
::punk::mix::base::_cli {*}$args
}
variable default_command status
package require punk::mix::base
package require punk::overlay
punk::overlay::custom_from_base [namespace current] ::punk::mix::base
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punkcheck::cli [namespace eval punkcheck::cli {
variable version
set version 0.1.0
}]
return

3078
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm

File diff suppressed because it is too large Load Diff
Loading…
Cancel
Save