Browse Source

make.tcl updates support for modules_tclX where X is tcl major version

master
Julian Noble 5 months ago
parent
commit
4838319af5
  1. 7
      src/bootsupport/modules/include_modules.config
  2. 3942
      src/bootsupport/modules/mime-1.7.0.tm
  3. 195
      src/bootsupport/modules/oolib-0.1.tm
  4. 3399
      src/bootsupport/modules/overtype-1.6.1.tm
  5. 3415
      src/bootsupport/modules/overtype-1.6.2.tm
  6. 75
      src/bootsupport/modules/overtype-1.6.5.tm
  7. 159
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  8. 107
      src/bootsupport/modules/punk/args-0.1.0.tm
  9. 6
      src/bootsupport/modules/punk/char-0.1.0.tm
  10. 13
      src/bootsupport/modules/punk/console-0.1.1.tm
  11. 19
      src/bootsupport/modules/punk/fileline-0.1.0.tm
  12. 970
      src/bootsupport/modules/punk/lib-0.1.1.tm
  13. 24
      src/bootsupport/modules/punk/mix/base-0.1.tm
  14. 252
      src/bootsupport/modules/punk/mix/cli-0.3.1.tm
  15. 248
      src/bootsupport/modules/punk/mix/cli-0.3.tm
  16. 4
      src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm
  17. 50
      src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  18. 26
      src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm
  19. 102
      src/bootsupport/modules/punk/mix/templates/layouts/project/src/make.tcl
  20. 53
      src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl
  21. 2
      src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/z
  22. BIN
      src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip
  23. 7
      src/bootsupport/modules/punk/mix/templates/utility/a b/tcltest.bat
  24. 37
      src/bootsupport/modules/punk/ns-0.1.0.tm
  25. 3
      src/bootsupport/modules/punk/path-0.1.0.tm
  26. 9
      src/bootsupport/modules/punk/repo-0.1.1.tm
  27. 6
      src/bootsupport/modules/punkcheck-0.1.0.tm
  28. 602
      src/bootsupport/modules/textblock-0.1.1.tm
  29. 9
      src/bootsupport/modules_tcl8/include_modules.config
  30. 253
      src/make.tcl
  31. 53
      src/modules/#modpod-modpodtest-999999.0a1.0/#modpod-loadscript.tcl
  32. 2
      src/modules/#modpod-modpodtest-999999.0a1.0/#z
  33. 181
      src/modules/#modpod-modpodtest-999999.0a1.0/modpodtest-999999.0a1.0.tm
  34. 120
      src/modules/#modpod-zipper-0.11/zipper-0.11.tm
  35. 28
      src/modules/#modpod-zipper-0.11/zipper.README
  36. 3
      src/modules/modpodtest-buildversion.txt
  37. 273
      src/modules/punk-0.1.tm
  38. 18
      src/modules/punk/aliascore-999999.0a1.0.tm
  39. 128
      src/modules/punk/ansi-999999.0a1.0.tm
  40. 31
      src/modules/punk/args-999999.0a1.0.tm
  41. 6
      src/modules/punk/char-999999.0a1.0.tm
  42. 195
      src/modules/punk/config-0.1.tm
  43. 12
      src/modules/punk/console-999999.0a1.0.tm
  44. 12
      src/modules/punk/fileline-999999.0a1.0.tm
  45. 324
      src/modules/punk/lib-999999.0a1.0.tm
  46. 24
      src/modules/punk/mix/base-0.1.tm
  47. 1119
      src/modules/punk/mix/cli-999999.0a1.0.tm
  48. 3
      src/modules/punk/mix/cli-buildversion.txt
  49. 5
      src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm
  50. 50
      src/modules/punk/mix/commandset/module-999999.0a1.0.tm
  51. 26
      src/modules/punk/mix/commandset/project-999999.0a1.0.tm
  52. 102
      src/modules/punk/mix/templates/layouts/project/src/make.tcl
  53. 53
      src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl
  54. 2
      src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/z
  55. BIN
      src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip
  56. 3
      src/modules/punk/path-999999.0a1.0.tm
  57. 12
      src/modules/punk/repl-0.1.tm
  58. 4
      src/modules/punk/repl/codethread-999999.0a1.0.tm
  59. 9
      src/modules/punk/repo-999999.0a1.0.tm
  60. 632
      src/modules/punk/zip-999999.0a1.0.tm
  61. 3
      src/modules/punk/zip-buildversion.txt
  62. 6
      src/modules/punkcheck-0.1.0.tm
  63. 9
      src/modules/shellfilter-0.1.9.tm
  64. 36
      src/modules/shellrun-0.1.1.tm
  65. 93
      src/modules/textblock-999999.0a1.0.tm
  66. 130
      src/punk86.vfs/boot.tcl
  67. 1
      src/punk86.vfs/config.tcl
  68. 20
      src/punk86.vfs/lib/app-punk/repl.tcl
  69. 36
      src/punk86.vfs/lib/gridplus2.11/LICENSE.GRIDPLUS
  70. 6871
      src/punk86.vfs/lib/gridplus2.11/gridplus.tcl
  71. 1
      src/punk86.vfs/lib/gridplus2.11/pkgIndex.tcl
  72. 3
      src/runtime/mapvfs.config
  73. BIN
      src/vendormodules/Thread-2.8.9.tm
  74. BIN
      src/vendormodules/Thread/platform/win32_x86_64-2.8.9.tm
  75. 143
      src/vendormodules/dictutils-0.2.tm
  76. BIN
      src/vendormodules/gridplus-2.11.tm
  77. 17
      src/vendormodules/include_modules.config
  78. 2
      src/vendormodules/md5-2.0.8.tm
  79. 700
      src/vendormodules/modpod-0.1.0.tm
  80. 705
      src/vendormodules/overtype-1.6.5.tm
  81. BIN
      src/vendormodules/packageTest-0.1.0.tm
  82. BIN
      src/vendormodules/tablelist-6.22.tm
  83. 1
      src/vendormodules/tablelist_tile-6.22.tm
  84. 2
      src/vendormodules/textutil/wcswidth-35.2.tm
  85. 11
      src/vendormodules_tcl8/include_modules.config
  86. BIN
      src/vendormodules_tcl9/Thread-3.0b3.tm
  87. BIN
      src/vendormodules_tcl9/Thread/platform/win32_x86_64_tcl9-3.0b3.tm
  88. 11
      src/vendormodules_tcl9/include_modules.config

7
src/bootsupport/include_modules.config → src/bootsupport/modules/include_modules.config

@ -1,4 +1,7 @@
#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.
#each entry - base module
set bootsupport_modules [list\
src/vendormodules cksum\
@ -58,7 +61,3 @@ set bootsupport_modules [list\
modules oolib\
]
#each entry - base subpath
set bootsupport_module_folders [list\
modules punk/mix/templates
]

3942
src/bootsupport/modules/mime-1.7.0.tm

File diff suppressed because it is too large Load Diff

195
src/bootsupport/modules/oolib-0.1.tm

@ -1,195 +0,0 @@
#JMN - api should be kept in sync with package patternlib where possible
#
package provide oolib [namespace eval oolib {
variable version
set version 0.1
}]
namespace eval oolib {
oo::class create collection {
variable o_data ;#dict
variable o_alias
constructor {} {
set o_data [dict create]
}
method info {} {
return [dict info $o_data]
}
method count {} {
return [dict size $o_data]
}
method isEmpty {} {
expr {[dict size $o_data] == 0}
}
method names {{globOrIdx {}}} {
if {[llength $globOrIdx]} {
if {[string is integer -strict $globOrIdx]} {
if {$idx < 0} {
set idx "end-[expr {abs($idx + 1)}]"
}
if {[catch {lindex [dict keys $o_data] $idx} result]} {
error "[self object] no such index : '$idx'"
} else {
return $result
}
} else {
#glob
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx]
}
} else {
return [dict keys $o_data]
}
}
#like names but without globbing
method keys {} {
dict keys $o_data
}
method key {{posn 0}} {
if {$posn < 0} {
set posn "end-[expr {abs($posn + 1)}]"
}
if {[catch {lindex [dict keys $o_data] $posn} result]} {
error "[self object] no such index : '$posn'"
} else {
return $result
}
}
method hasKey {key} {
dict exists $o_data $key
}
method get {} {
return $o_data
}
method items {} {
return [dict values $o_data]
}
method item {key} {
if {[string is integer -strict $key]} {
if {$key > 0} {
set valposn [expr {(2*$key) +1}]
return [lindex $o_data $valposn]
} else {
set key "end-[expr {abs($key + 1)}]"
return [lindex [dict keys $o_data] $key]
}
}
if {[dict exists $o_data $key]} {
return [dict get $o_data $key]
}
}
#inverse lookup
method itemKeys {value} {
set value_indices [lsearch -all [dict values $o_data] $value]
set keylist [list]
foreach i $value_indices {
set idx [expr {(($i + 1) *2) -2}]
lappend keylist [lindex $o_data $idx]
}
return $keylist
}
method search {value args} {
set matches [lsearch {*}$args [dict values $o_data] $value]
if {"-inline" in $args} {
return $matches
} else {
set keylist [list]
foreach i $matches {
set idx [expr {(($i + 1) *2) -2}]
lappend keylist [lindex $o_data $idx]
}
return $keylist
}
}
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists?
method alias {newAlias existingKeyOrAlias} {
if {[string is integer -strict $newAlias]} {
error "[self object] collection key alias cannot be integer"
}
if {[string length $existingKeyOrAlias]} {
set o_alias($newAlias) $existingKeyOrAlias
} else {
unset o_alias($newAlias)
}
}
method aliases {{key ""}} {
if {[string length $key]} {
set result [list]
foreach {n v} [array get o_alias] {
if {$v eq $key} {
lappend result $n $v
}
}
return $result
} else {
return [array get o_alias]
}
}
#if the supplied index is an alias, return the underlying key; else return the index supplied.
method realKey {idx} {
if {[catch {set o_alias($idx)} key]} {
return $idx
} else {
return $key
}
}
method add {value key} {
if {[string is integer -strict $key]} {
error "[self object] collection key must not be an integer. Use another structure if integer keys required"
}
if {[dict exists $o_data $key]} {
error "[self object] col_processors object error: key '$key' already exists in collection"
}
dict set o_data $key $value
return [expr {[dict size $o_data] - 1}] ;#return index of item
}
method remove {idx {endRange ""}} {
if {[string length $endRange]} {
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time"
}
if {[string is integer -strict $idx]} {
if {$idx < 0} {
set idx "end-[expr {abs($idx+1)}]"
}
set key [lindex [dict keys $o_data] $idx]
set posn $idx
} else {
set key $idx
set posn [lsearch -exact [dict keys $o_data] $key]
if {$posn < 0} {
error "[self object] no such index: '$idx' in this collection"
}
}
dict unset o_data $key
return
}
method clear {} {
set o_data [dict create]
return
}
method reverse {} {
set dictnew [dict create]
foreach k [lreverse [dict keys $o_data]] {
dict set dictnew $k [dict get $o_data $k]
}
set o_data $dictnew
return
}
#review - cmd as list vs cmd as script?
method map {cmd} {
set seed [list]
dict for {k v} $o_data {
lappend seed [uplevel #0 [list {*}$cmd $v]]
}
return $seed
}
method objectmap {cmd} {
set seed [list]
dict for {k v} $o_data {
lappend seed [uplevel #0 [list $v {*}$cmd]]
}
return $seed
}
}
}

3399
src/bootsupport/modules/overtype-1.6.1.tm

File diff suppressed because it is too large Load Diff

3415
src/bootsupport/modules/overtype-1.6.2.tm

File diff suppressed because it is too large Load Diff

75
src/bootsupport/modules/overtype-1.6.4.tm → src/bootsupport/modules/overtype-1.6.5.tm

@ -7,7 +7,7 @@
# (C) Julian Noble 2003-2023
#
# @@ Meta Begin
# Application overtype 1.6.4
# Application overtype 1.6.5
# Meta platform tcl
# Meta license BSD
# @@ Meta End
@ -17,7 +17,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin overtype_module_overtype 0 1.6.4]
#[manpage_begin overtype_module_overtype 0 1.6.5]
#[copyright "2024"]
#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}]
#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}]
@ -146,66 +146,12 @@ tcl::namespace::eval overtype {
}
#proc overtype::stripansi {text} {
# variable escape_terminals ;#dict
# variable ansi_2byte_codes_dict
# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway
# if {[string first \033 $text] <0 && [string first \009c $text] <0} {
# #\033 same as \x1b
# return $text
# }
#
# set text [convert_g0 $text]
#
# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character.
# #line endings can theoretically occur within an ansi escape sequence (review e.g title?)
# set inputlist [split $text ""]
# set outputlist [list]
#
# set 2bytecodes [dict values $ansi_2byte_codes_dict]
#
# set in_escapesequence 0
# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls
# set i 0
# foreach u $inputlist {
# set v [lindex $inputlist $i+1]
# set uv ${u}${v}
# if {$in_escapesequence eq "2b"} {
# #2nd byte - done.
# set in_escapesequence 0
# } elseif {$in_escapesequence != 0} {
# set escseq [tcl::dict::get $escape_terminals $in_escapesequence]
# if {$u in $escseq} {
# set in_escapesequence 0
# } elseif {$uv in $escseq} {
# set in_escapseequence 2b ;#flag next byte as last in sequence
# }
# } else {
# #handle both 7-bit and 8-bit CSI and OSC
# if {[regexp {^(?:\033\[|\u009b)} $uv]} {
# set in_escapesequence CSI
# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} {
# set in_escapesequence OSC
# } elseif {$uv in $2bytecodes} {
# #self-contained e.g terminal reset - don't pass through.
# set in_escapesequence 2b
# } else {
# lappend outputlist $u
# }
# }
# incr i
# }
# return [join $outputlist ""]
#}
proc overtype::string_columns {text} {
if {[punk::ansi::ta::detect $text]} {
#error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length"
set text [punk::ansi::stripansi $text]
#error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::ansistrip. Alternatively try punk::ansi::printing_length"
set text [punk::ansi::ansistrip $text]
}
return [punk::char::ansifreestring_width $text]
}
@ -265,7 +211,7 @@ tcl::namespace::eval overtype {
variable default_ellipsis_horizontal
if {[llength $args] < 2} {
error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext}
error {usage: ?-width <int>? ?-startcolumn <int>? ?-transparent [0|1|<char>]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext}
}
lassign [lrange $args end-1 end] underblock overblock
set opts [tcl::dict::create\
@ -1059,7 +1005,7 @@ tcl::namespace::eval overtype {
set show_ellipsis 0
}
#set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end]
if {[tcl::string::trim [punk::ansi::stripansi $lostdata]] eq ""} {
if {[tcl::string::trim [punk::ansi::ansistrip $lostdata]] eq ""} {
set show_ellipsis 0
}
}
@ -1837,8 +1783,9 @@ tcl::namespace::eval overtype {
set pt [tcl::string::map $cp437_map $pt]
}
foreach grapheme [punk::char::grapheme_split $pt] {
#an ugly hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty.
#an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty.
#.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together.
#todo - test decimal value instead, compare performance
switch -- $grapheme {
" " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? -
a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y -
@ -3460,9 +3407,9 @@ proc overtype::blocksize {textblock} {
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#stripansi on entire block in one go rather than line by line - result should be the same - review - make tests
#ansistrip on entire block in one go rather than line by line - result should be the same - review - make tests
if {[punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::stripansi $textblock]
set textblock [punk::ansi::ansistrip $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list
@ -3677,7 +3624,7 @@ tcl::namespace::eval overtype {
## Ready
package provide overtype [tcl::namespace::eval overtype {
variable version
set version 1.6.4
set version 1.6.5
}]
return

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

@ -265,13 +265,13 @@ tcl::namespace::eval punk::ansi::class {
}
set opts_width [tcl::dict::get $opts -width]
if {$opts_width eq ""} {
return [punk::ansi::stripansiraw [$o_ansistringobj get]]
return [punk::ansi::ansistripraw [$o_ansistringobj get]]
} elseif {$opts_width eq "auto"} {
lassign [punk::console::get_size] _cols columns _rows rows
set displaycols [expr {$columns -4}] ;#review
return [overtype::renderspace -width $displaycols -wrap 1 "" [punk::ansi::stripansiraw [$o_ansistringobj get]]]
return [overtype::renderspace -width $displaycols -wrap 1 "" [punk::ansi::ansistripraw [$o_ansistringobj get]]]
} elseif {[tcl::string::is integer -strict $opts_width] && $opts_width > 0} {
return [overtype::renderspace -width $opts_width -wrap 1 "" [punk::ansi::stripansiraw [$o_ansistringobj get]]]
return [overtype::renderspace -width $opts_width -wrap 1 "" [punk::ansi::ansistripraw [$o_ansistringobj get]]]
} else {
error "viewchars unrecognised value for -width. Try auto or a positive integer"
}
@ -420,7 +420,7 @@ tcl::namespace::eval punk::ansi {
get_*\
move*\
reset*\
strip*\
ansistrip*\
test_decaln\
titleset\
@ -750,7 +750,7 @@ tcl::namespace::eval punk::ansi {
#mqj
#m = boxd_lur
#don't call detect_g0 in here. Leave for caller. e.g stripansi uses detect_g0 to decide whether to call this.
#don't call detect_g0 in here. Leave for caller. e.g ansistrip uses detect_g0 to decide whether to call this.
set re_g0_open_or_close {\x1b\(0|\x1b\(B}
set parts [::punk::ansi::ta::_perlish_split $re_g0_open_or_close $text]
@ -813,7 +813,7 @@ tcl::namespace::eval punk::ansi {
proc g0 {text} {
return \x1b(0$text\x1b(B
}
proc stripansi_gx {text} {
proc ansistrip_gx {text} {
#e.g "\033(0" - select VT100 graphics for character set G0
#e.g "\033(B" - reset
#e.g "\033)0" - select VT100 graphics for character set G1
@ -822,6 +822,9 @@ tcl::namespace::eval punk::ansi {
#return [convert_g0 $text]
return [tcl::string::map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text]
}
proc stripansi_gx {text} {
return [tcl::string::map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text]
}
#CSI <n> m = SGR (Select Graphic Rendition)
@ -1085,7 +1088,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#This is an in depth analysis of the xterm colour set which gives names(*) to all of the 256 colours and describes possible indexing by Hue,Luminance,Saturation
#https://www.wowsignal.io/articles/xterm256
#*The names are wildly-imaginative, often unintuitively so, and multiple (5?) given for each colour - so they are unlikely to be of practical use or any sort of standard.
# *The names are wildly-imaginative, often unintuitively so, and multiple (5?) given for each colour - so they are unlikely to be of practical use or any sort of standard.
#e.g who is to know that 'Rabbit Paws', 'Forbidden Thrill' and 'Tarsier' refer to a particular shade of pinky-red? (code 95)
#Perhaps it's an indication that colour naming once we get to 256 colours or more is a fool's errand anyway.
#The xterm names are boringly unimaginative - and also have some oddities such as:
@ -1872,7 +1875,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
$t configure -frametype {}
$t configure_column 0 -headers [list "[tcl::string::totitle $g] colours"]
$t configure_column 0 -header_colspans [list all]
$t configure_column 0 -header_colspans [list any]
$t configure -ansibase_header [a+ {*}$fc web-black Web-white]
lappend grouptables [$t print]
$t destroy
@ -1919,7 +1922,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
$t configure -frametype block
$t configure_column 0 -headers [list "X11"]
$t configure_column 0 -header_colspans [list all]
$t configure_column 0 -header_colspans [list any]
$t configure -ansibase_header [a+ {*}$fc web-black Web-white]
lappend comparetables [$t print]
$t destroy
@ -1940,7 +1943,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
$t configure -frametype block
$t configure_column 0 -headers [list "Web"]
$t configure_column 0 -header_colspans [list all]
$t configure_column 0 -header_colspans [list any]
$t configure -ansibase_header [a+ {*}$fc web-black Web-white]
lappend comparetables [$t print]
$t destroy
@ -2013,39 +2016,39 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
package require overtype ;# circular dependency - many components require overtype. Here we only need it for nice layout in the a? query proc - so we'll do a soft-dependency by only loading when needed and also wrapping in a try
package require textblock
append out [textblock::join $indent [tcl::string::map $strmap $settings_applied]] \n
append out [textblock::join $indent [tcl::string::trim $SGR_colour_map \n]] \n
append out [textblock::join $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n
append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n
append out [textblock::join -- $indent [tcl::string::trim $SGR_colour_map \n]] \n
append out [textblock::join -- $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n
set bgname "Web-white"
set map1 [colourmap1 -bg $bgname -forcecolour $opt_forcecolour]
set map1 [overtype::centre -transparent 1 $map1 "[a {*}$fc black $bgname]Standard colours[a]"]
set map2 [colourmap2 -bg $bgname -forcecolour $opt_forcecolour]
set map2 [overtype::centre -transparent 1 $map2 "[a {*}$fc black $bgname]High-intensity colours[a]"]
append out [textblock::join $indent [textblock::join -- $map1 $map2]] \n
append out [textblock::join -- $indent [textblock::join -- $map1 $map2]] \n
append out "[a+ {*}$fc web-white]216 colours of 256 terminal colours (To see names, use: a? term ?pastel? ?rainbow?)[a]" \n
append out [textblock::join $indent [colourblock_216 -forcecolour $opt_forcecolour]] \n
append out [textblock::join -- $indent [colourblock_216 -forcecolour $opt_forcecolour]] \n
append out "[a+ {*}$fc web-white]24 Greyscale colours[a]" \n
append out [textblock::join $indent [colourblock_24 -forcecolour $opt_forcecolour]] \n
append out [textblock::join -- $indent [colourblock_24 -forcecolour $opt_forcecolour]] \n
append out \n
append out [textblock::join $indent "Example: \[a+ Term-92 term-49\]text\[a] -> [a+ {*}$fc Term-92 term-49]text[a]"] \n
append out [textblock::join $indent "Example: \[a+ Term-lightsteelblue term-gold1\]text\[a] -> [a+ {*}$fc Term-lightsteelblue term-gold1]text[a]"] \n
append out [textblock::join $indent "Example: \[a+ term-lightsteelblue Term-gold1\]text\[a] -> [a+ {*}$fc term-lightsteelblue Term-gold1]text[a]"] \n
append out [textblock::join -- $indent "Example: \[a+ Term-92 term-49\]text\[a] -> [a+ {*}$fc Term-92 term-49]text[a]"] \n
append out [textblock::join -- $indent "Example: \[a+ Term-lightsteelblue term-gold1\]text\[a] -> [a+ {*}$fc Term-lightsteelblue term-gold1]text[a]"] \n
append out [textblock::join -- $indent "Example: \[a+ term-lightsteelblue Term-gold1\]text\[a] -> [a+ {*}$fc term-lightsteelblue Term-gold1]text[a]"] \n
append out \n
append out "[a+ {*}$fc web-white]16 Million colours[a]" \n
#tcl::dict::set WEB_colour_map mediumvioletred 199-21-133 ;# #C71585
append out [textblock::join $indent "Example: \[a+ rgb-199-21-133\]text\[a] -> [a+ {*}$fc rgb-199-21-133]text[a]"] \n
append out [textblock::join $indent "Example: \[a+ Rgb#C71585\]text\[a] -> [a+ {*}$fc Rgb#C71585]text[a]"] \n
append out [textblock::join $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n
append out [textblock::join -- $indent "Example: \[a+ rgb-199-21-133\]text\[a] -> [a+ {*}$fc rgb-199-21-133]text[a]"] \n
append out [textblock::join -- $indent "Example: \[a+ Rgb#C71585\]text\[a] -> [a+ {*}$fc Rgb#C71585]text[a]"] \n
append out [textblock::join -- $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n
append out \n
append out "[a+ {*}$fc web-white]Web colours[a]" \n
append out [textblock::join $indent "To see all names use: a? web"] \n
append out [textblock::join $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n
append out [textblock::join $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n
append out [textblock::join -- $indent "To see all names use: a? web"] \n
append out [textblock::join -- $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n
append out [textblock::join -- $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n
append out \n
append out [textblock::join $indent "Example: \[a+ Web-springgreen web-crimson\]text\[a] -> [a+ {*}$fc Web-springgreen web-coral]text[a]"] \n
append out [textblock::join -- $indent "Example: \[a+ Web-springgreen web-crimson\]text\[a] -> [a+ {*}$fc Web-springgreen web-coral]text[a]"] \n
append out \n
append out "[a+ {*}$fc web-white]X11 colours[a] - mostly match Web colours" \n
append out [textblock::join $indent "To see differences: a? x11"] \n
append out [textblock::join -- $indent "To see differences: a? x11"] \n
if {[tcl::info::exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} {
append out \n
@ -2261,15 +2264,29 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set sgr_cache [tcl::dict::create]
#sgr_cache clear called by punk::console::ansi when set to off
proc sgr_cache {{action ""}} {
proc sgr_cache {args} {
set argd [punk::args::get_dict {
*proc -name punk::ansi::sgr_cache -help "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes)
"
-action -default "" -choices "clear" -help "-action clear will unset the keys in the punk::ansi::sgr_cache dict
This is called automatically when setting 'colour false' in the console"
-pretty -default 1 -type boolean -help "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output"
*values -min 0 -max 0
} $args]
set action [dict get $argd opts -action]
set pretty [dict get $argd opts -pretty]
variable sgr_cache
if {$action ni {"" clear}} {
error "sgr_cache action '$action' not understood. Valid actions: clear"
}
if {$action eq "clear"} {
set sgr_cache [tcl::dict::create]
return "sgr_cache cleared"
}
if {$pretty} {
#return [pdict -channel none sgr_cache */%str,%ansiview]
return [pdict -channel none sgr_cache */%rpadstr-"sample",%ansiviewstyle]
}
if {[catch {
set termwidth [tcl::dict::get [punk::console::get_size] columns]
} errM]} {
@ -2311,7 +2328,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#function name part of cache-key because a and a+ return slightly different results (a has leading reset)
variable sgr_cache
set cache_key a+$args ;#ensure cache_key static - we may remove for example 'forcecolour' from args - but it needs to remain part of cache_key
set cache_key "a+ $args" ;#ensure cache_key static - we may remove for example 'forcecolour' from args - but it needs to remain part of cache_key
if {[tcl::dict::exists $sgr_cache $cache_key]} {
return [tcl::dict::get $sgr_cache $cache_key]
}
@ -2670,7 +2687,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#It's important to put the functionname in the cache-key because a and a+ return slightly different results
variable sgr_cache
set cache_key a_$args
set cache_key "a $args"
if {[tcl::dict::exists $sgr_cache $cache_key]} {
return [tcl::dict::get $sgr_cache $cache_key]
}
@ -2681,7 +2698,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
variable TERM_colour_map
set colour_disabled 0
#whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache clear
#whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache -action clear
if {[tcl::info::exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} {
set colour_disabled 1
}
@ -3381,10 +3398,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#arguably - \b and \r are cursor move operations too - so processing them here is not very symmetrical - review
#the purpose of backspace (or line cr) in embedded text is unclear. Should it allow some sort of character combining/overstrike as it has sometimes done historically (nroff/less)? e.g a\b` as an alternative combiner or bolding if same char
#This should presumably only be done if the over_strike (os) capability is enabled in the terminal. Either way - it presumably won't affect printing width?
set line [punk::ansi::stripansi $line]
set line [punk::ansi::ansistrip $line]
#we can't use simple \b processing if we get ansi codes and aren't actually processing them (e.g moves)
set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after stripansi - some like BEL are part of ansi
set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after ansistrip - some like BEL are part of ansi
#backspace 0x08 only erases* printing characters anyway - so presumably order of processing doesn't matter
#(* more correctly - moves cursor back)
#Note some terminals process backspace before \v - which seems quite wrong
@ -3500,6 +3517,40 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#ever so slightly slower on short strings - much faster than split_at_codes version for large/complex ansi blocks
proc ansistrip {text} {
#*** !doctools
#[call [fun ansistrip] [arg text] ]
#[para]Return a string with ansi codes stripped out
#[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs)
if {[punk::ansi::ta::detect_g0 $text]} {
set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters
}
set parts [punk::ansi::ta::split_codes $text]
set out ""
foreach {pt code} $parts {
append out $pt
}
return $out
}
#interp alias {} stripansi {} ::punk::ansi::ansistrip
proc ansistripraw {text} {
#*** !doctools
#[call [fun ansistripraw] [arg text] ]
#[para]Return a string with ansi codes stripped out
#[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode.
#[para]ie instead of a horizontal line you may see: qqqqqq
set parts [punk::ansi::ta::split_codes $text]
set out ""
foreach {pt code} $parts {
append out $pt
}
return $out
}
#interp alias {} stripansiraw {} ::punk::ansi::ansistripraw
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::ansi ---}]
}
@ -4281,16 +4332,16 @@ tcl::namespace::eval punk::ansi::ta {
#*** !doctools
#[call [fun strip] [arg text]]
#[para]Return text stripped of Ansi codes
#[para]This is a tailcall to punk::ansi::stripansi
tailcall stripansi $text
#[para]This is a tailcall to punk::ansi::ansistrip
tailcall ansistrip $text
}
proc length {text} {
#*** !doctools
#[call [fun length] [arg text]]
#[para]Return the character length after stripping ansi codes - not the printing length
#we can use stripansiraw to avoid g0 conversion - as the length should remain the same
tcl::string::length [stripansiraw $text]
#we can use ansistripraw to avoid g0 conversion - as the length should remain the same
tcl::string::length [ansistripraw $text]
}
#todo - handle newlines
#not in perl ta
@ -5439,11 +5490,8 @@ tcl::namespace::eval punk::ansi::class {
}
}
tcl::namespace::eval punk::ansi {
proc stripansi {text} [string map [list <re> $::punk::ansi::ta::re_ansi_split] {
#*** !doctools
#[call [fun stripansi] [arg text] ]
#[para]Return a string with ansi codes stripped out
#[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs)
proc stripansi3 {text} [string map [list <re> $::punk::ansi::ta::re_ansi_split] {
#using detect costs us a couple of uS - but saves time on plain text
#we should probably leave this for caller - otherwise it ends up being called more than necessary
@ -5459,12 +5507,7 @@ tcl::namespace::eval punk::ansi {
punk::ansi::ta::Do_split_at_codes_join $text {<re>}
}]
proc stripansiraw {text} [string map [list <re> $::punk::ansi::ta::re_ansi_split] {
#*** !doctools
#[call [fun stripansi] [arg text] ]
#[para]Return a string with ansi codes stripped out
#[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode.
#[para]ie instead of a horizontal line you may see: qqqqqq
proc stripansiraw3 {text} [string map [list <re> $::punk::ansi::ta::re_ansi_split] {
#join [::punk::ansi::ta::split_at_codes $text] ""
punk::ansi::ta::Do_split_at_codes_join $text {<re>}
@ -5890,7 +5933,7 @@ tcl::namespace::eval punk::ansi::ansistring {
#[para]Returns the count of visible graphemes and non-ansi control characters
#[para]Incomplete! grapheme clustering support not yet implemented - only diacritics are currently clustered to count as one grapheme.
#[para]This will not count strings hidden inside a 'privacy message' or other ansi codes which may have content between their opening escape and their termination sequence.
#[para]This is not quite equivalent to calling string length on the result of stripansi $string due to diacritics and/or grapheme combinations
#[para]This is not quite equivalent to calling string length on the result of ansistrip $string due to diacritics and/or grapheme combinations
#[para]Note that this returns the number of characters in the payload (after applying combiners)
#It is not always the same as the width of the string as rendered on a terminal due to 2wide Unicode characters and the usual invisible control characters such as \r and \n
#[para]To get the width, use punk::ansi::printing_length instead, which is also ansi aware.
@ -5902,17 +5945,17 @@ tcl::namespace::eval punk::ansi::ansistring {
set string [regsub -all $re_diacritics $string ""]
#we want length to return number of glyphs.. not screen width. Has to be consistent with index function
tcl::string::length [stripansi $string]
tcl::string::length [ansistrip $string]
}
#included as a test/verification - slightly slower.
#grapheme split version may end up being used once it supports unicode grapheme clusters
proc count2 {string} {
#we want count to return number of glyphs.. not screen width. Has to be consistent with index function
return [llength [punk::char::grapheme_split [stripansi $string]]]
return [llength [punk::char::grapheme_split [ansistrip $string]]]
}
proc length {string} {
tcl::string::length [stripansi $string]
tcl::string::length [ansistrip $string]
}
proc _splits_trimleft {sclist} {
@ -6022,9 +6065,9 @@ tcl::namespace::eval punk::ansi::ansistring {
#[para]The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output.
#[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST)
#[para]It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them.
#[para]If the caller wants just the character - they should use a normal string index after calling stripansi, or call stripansi afterwards.
#[para]As any operation using end-+<int> will need to strip ansi to precalculate the length anyway; the caller should probably just use stripansi and standard string index if the ansi coded output isn't required and they are using and end-based index.
#[para]In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using stripansi and normal string operations on that.
#[para]If the caller wants just the character - they should use a normal string index after calling ansistrap, or call ansistrip afterwards.
#[para]As any operation using end-+<int> will need to strip ansi to precalculate the length anyway; the caller should probably just use ansistrip and standard string index if the ansi coded output isn't required and they are using and end-based index.
#[para]In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using ansistrip and normal string operations on that.
#[para]The returned character will (possibly) have a leading ansi escape sequence but no trailing escape sequence - even if the string was taken from a position immediately before a reset or other SGR ansi code
#[para]The ansi-code prefix in the returned string is built up by concatenating previous SGR ansi codes seen - but it is optimised to re-start the process if any full SGR reset is encountered.
#[para]The code sequence doesn't detect individual properties being turned on and then off again, only full resets; so in some cases the ansi-prefix may not be as short as it could be.

107
src/bootsupport/modules/punk/args-0.1.0.tm

@ -267,6 +267,9 @@ tcl::namespace::eval punk::args {
#[list_begin definitions]
#todo? -synonym ? (applies to opts only not values)
#e.g -background -synonym -bg -default White
proc Get_argspecs {optionspecs args} {
variable argspec_cache
variable argspecs
@ -332,7 +335,8 @@ tcl::namespace::eval punk::args {
set in_record 0
foreach rawline $linelist {
set recordsofar [tcl::string::cat $linebuild $rawline]
if {![tcl::info::complete $recordsofar]} {
#ansi colours can stop info complete from working (contain square brackets)
if {![tcl::info::complete [punk::ansi::ansistrip $recordsofar]]} {
#append linebuild [string trimleft $rawline] \n
if {$in_record} {
if {[tcl::string::length $lastindent]} {
@ -436,6 +440,9 @@ tcl::namespace::eval punk::args {
}
none - any - ansistring {
}
list {
}
default {
#todo - disallow unknown types unless prefixed with custom-
@ -494,6 +501,9 @@ tcl::namespace::eval punk::args {
}
dict - dictionary {
set v dict
}
list {
}
default {
#todo - disallow unknown types unless prefixed with custom-
@ -568,7 +578,9 @@ tcl::namespace::eval punk::args {
"" - none {
if {$is_opt} {
tcl::dict::set spec_merged -type none
if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} {
tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it.
}
lappend opt_solos $argname
} else {
#-solo only valid for flags
@ -687,6 +699,8 @@ tcl::namespace::eval punk::args {
}
proc arg_error {msg spec_dict {badarg ""}} {
# use basic colours here to support terminals without extended colours
#todo - add checks column (e.g -minlen -maxlen)
set errmsg $msg
if {![catch {package require textblock}]} {
if {[catch {
@ -694,18 +708,21 @@ tcl::namespace::eval punk::args {
set procname [punk::lib::dict_getdef $spec_dict proc_info -name ""]
set prochelp [punk::lib::dict_getdef $spec_dict proc_info -help ""]
set t [textblock::class::table new [a+ web-yellow]Usage[a]]
#set t [textblock::class::table new [a+ web-yellow]Usage[a]]
set t [textblock::class::table new [a+ brightyellow]Usage[a]]
set blank_header_col [list ""]
if {$procname ne ""} {
lappend blank_header_col ""
set procname_display [a+ web-white]$procname[a]
#set procname_display [a+ web-white]$procname[a]
set procname_display [a+ brightwhite]$procname[a]
} else {
set procname_display ""
}
if {$prochelp ne ""} {
lappend blank_header_col ""
set prochelp_display [a+ web-white]$prochelp[a]
#set prochelp_display [a+ web-white]$prochelp[a]
set prochelp_display [a+ brightwhite]$prochelp[a]
} else {
set prochelp_display ""
}
@ -728,9 +745,12 @@ tcl::namespace::eval punk::args {
$t configure_header 2 -values {Arg Type Default Multiple Help}
}
set c_default [a+ web-white Web-limegreen]
set c_badarg [a+ web-crimson]
set greencheck [a+ web-limegreen]\u2713[a]
#set c_default [a+ web-white Web-limegreen]
set c_default [a+ brightwhite Brightgreen]
#set c_badarg [a+ web-crimson]
set c_badarg [a+ brightred]
#set greencheck [a+ web-limegreen]\u2713[a]
set greencheck [a+ brightgreen]\u2713[a]
foreach arg [dict get $spec_dict opt_names] {
set arginfo [dict get $spec_dict arg_info $arg]
@ -779,7 +799,8 @@ tcl::namespace::eval punk::args {
}
$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ web-white] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow]
#$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ web-white] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow]
$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow]
$t configure -maxwidth 80
append errmsg [$t print]
$t destroy
@ -799,6 +820,11 @@ tcl::namespace::eval punk::args {
return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg
}
#todo - a version of get_dict that supports punk::lib::tstr templating
#rename get_dict
#provide ability to look up and reuse definitions from ids etc
#
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values
#If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags.
#only supports -flag val pairs, not solo options
@ -849,7 +875,7 @@ tcl::namespace::eval punk::args {
#this would be important in the case where the function to be wrapped has never been called - but the wrapper needs info about the downstream options
#we would like to avoid the ugliness of trying to parse a proc body to scrape the specification.
#we may still need to do a basic scan of the proc body to determine if it at least contains the string punk::args::get_dict - but that is slightly less odious.
error "unsupported"
error "unsupported number of arguments for punk::args::get_dict"
set inopt 0
set k ""
set i 0
@ -887,8 +913,12 @@ tcl::namespace::eval punk::args {
#for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default.
#-default value must not be appended to if argname not yet in flagsreceived
#todo: -minmultiple -maxmultiple ?
set opts $opt_defaults
if {[set eopts [lsearch -exact $rawargs "--"]] >= 0} {
lappend flagsreceived --
set values [lrange $rawargs $eopts+1 end]
set arglist [lrange $rawargs 0 $eopts-1]
set maxidx [expr {[llength $arglist]-1}]
@ -908,7 +938,7 @@ tcl::namespace::eval punk::args {
#review - what if user sets first value that happens to match a default?
if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} {
#first occurrence of this flag, whilst stored value matches default
tcl::dict::set opts $fullopt $flagval
tcl::dict::set opts $fullopt [list $flagval]
} else {
tcl::dict::lappend opts $fullopt $flagval
}
@ -997,7 +1027,7 @@ tcl::namespace::eval punk::args {
#review - what if user sets first value that happens to match a default?
if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} {
#first occurrence of this flag, whilst stored value matches default
tcl::dict::set opts $fullopt $flagval
tcl::dict::set opts $fullopt [list $flagval]
} else {
tcl::dict::lappend opts $fullopt $flagval
}
@ -1079,7 +1109,7 @@ tcl::namespace::eval punk::args {
if {[tcl::dict::get $arg_info $valname -multiple]} {
if {[tcl::dict::exists $val_defaults $valname] && ([tcl::dict::get $val_defaults $valname] eq [tcl::dict::get $values_dict $valname])} {
#current stored val equals defined default - don't include default in the list we build up
tcl::dict::set values_dict $valname $val
tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list
} else {
tcl::dict::lappend values_dict $valname $val
}
@ -1146,6 +1176,7 @@ tcl::namespace::eval punk::args {
}
#todo - truncate/summarize values in error messages
#todo - allow defaults outside of choices/ranges
@ -1189,7 +1220,7 @@ tcl::namespace::eval punk::args {
package require punk::ansi
set vlist_check [list]
foreach e $vlist {
lappend vlist_check [punk::ansi::stripansi $e]
lappend vlist_check [punk::ansi::ansistrip $e]
}
} else {
#validate_without_ansi 0
@ -1205,6 +1236,9 @@ tcl::namespace::eval punk::args {
}
if {$is_default eq [llength $vlist]} {
set is_default 1
} else {
#important to set 0 here too e.g if only one element of many matches default
set is_default 0
}
}
#puts "argname:$argname v:$v is_default:$is_default"
@ -1214,6 +1248,32 @@ tcl::namespace::eval punk::args {
if {$is_default == 0} {
switch -- $type {
any {}
list {
foreach e_check $vlist_check {
if {![tcl::string::is list -strict $e_check]} {
arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs $argname
}
if {[tcl::dict::size $thisarg_checks]} {
tcl::dict::for {checkopt checkval} $thisarg_checks {
switch -- $checkopt {
-minlen {
# -1 for disable is as good as zero
if {[llength $e_check] < $checkval} {
arg_error "Option $argname for [Get_caller] requires list with -minlen $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs $argname
}
}
-maxlen {
if {$checkval ne "-1"} {
if {[llength $e_check] > $checkval} {
arg_error "Option $argname for [Get_caller] requires list with -maxlen $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs $argname
}
}
}
}
}
}
}
}
string {
if {[tcl::dict::size $thisarg_checks]} {
foreach e_check $vlist_check {
@ -1295,6 +1355,25 @@ tcl::namespace::eval punk::args {
if {[llength $e_check] %2 != 0} {
arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs $argname
}
if {[tcl::dict::size $thisarg_checks]} {
tcl::dict::for {checkopt checkval} $thisarg_checks {
switch -- $checkopt {
-minlen {
# -1 for disable is as good as zero
if {[tcl::dict::size $e_check] < $checkval} {
arg_error "Option $argname for [Get_caller] requires dict with -minlen $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs $argname
}
}
-maxlen {
if {$checkval ne "-1"} {
if {[tcl::dict::size $e_check] > $checkval} {
arg_error "Option $argname for [Get_caller] requires dict with -maxlen $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs $argname
}
}
}
}
}
}
}
}
alnum -
@ -1369,7 +1448,7 @@ tcl::namespace::eval punk::args {
}
}
if {$is_strip_ansi} {
set stripped_list [lmap e $vlist {punk::ansi::stripansi $e}] ;#no faster or slower, but more concise than foreach
set stripped_list [lmap e $vlist {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach
if {[tcl::dict::get $thisarg -multiple]} {
if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} {
tcl::dict::set opts $argname $stripped_list

6
src/bootsupport/modules/punk/char-0.1.0.tm

@ -1950,7 +1950,7 @@ tcl::namespace::eval punk::char {
#we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!)
#anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error
#if {[tcl::string::first \033 $text] >= 0} {
# error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first"
# error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first"
#}
@ -2057,7 +2057,7 @@ tcl::namespace::eval punk::char {
#we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!)
#anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error
#if {[tcl::string::first \033 $text] >= 0} {
# error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first"
# error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first"
#}
@ -2161,7 +2161,7 @@ tcl::namespace::eval punk::char {
#we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!)
#anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error
#if {[tcl::string::first \033 $text] >= 0} {
# error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first"
# error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first"
#}

13
src/bootsupport/modules/punk/console-0.1.1.tm

@ -51,7 +51,7 @@ namespace eval punk::console {
variable ansi_available -1 ;#default -1 for unknown. Leave it this way so test for ansi support is run.
#-1 still evaluates to true - as the modern assumption for ansi availability is true
#only false if ansi_available has been set 0 by test_can_ansi
#support stripansi for legacy windows terminals
#support ansistrip for legacy windows terminals
# --
variable ansi_wanted 2 ;#2 for default assumed yes, will be set to -1 for automatically unwanted when ansi unavailable values of 0 or 1 won't be autoset
@ -780,7 +780,7 @@ namespace eval punk::console {
#stdout
variable ansi_wanted
if {$ansi_wanted <= 0} {
puts -nonewline [punk::ansi::stripansiraw [::punk::ansi::a?]]
puts -nonewline [punk::ansi::ansistripraw [::punk::ansi::a?]]
} else {
tailcall ansi::a? {*}$args
}
@ -806,7 +806,7 @@ namespace eval punk::console {
proc code_a? {args} {
variable ansi_wanted
if {$ansi_wanted <= 0} {
return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]]
return [punk::ansi::ansistripraw [::punk::ansi::a? {*}$args]]
} else {
tailcall ::punk::ansi::a? {*}$args
}
@ -833,7 +833,7 @@ namespace eval punk::console {
false -
no {
set ansi_wanted 0
punk::ansi::sgr_cache clear
punk::ansi::sgr_cache -action clear
}
default {
set ansi_wanted 2
@ -859,7 +859,7 @@ namespace eval punk::console {
if {$on} {
if {$colour_disabled} {
#change of state
punk::ansi::sgr_cache clear
punk::ansi::sgr_cache -action clear
catch {punk::repl::reset_prompt}
set colour_disabled 0
}
@ -867,7 +867,7 @@ namespace eval punk::console {
#we don't disable a/a+ entirely - they must still emit underlines/bold/reverse
if {!$colour_disabled} {
#change of state
punk::ansi::sgr_cache clear
punk::ansi::sgr_cache -action clear
catch {punk::repl::reset_prompt}
set colour_disabled 1
}
@ -1811,7 +1811,6 @@ interp alias {} colour {} punk::console::colour
interp alias {} ansi {} punk::console::ansi
interp alias {} color {} punk::console::colour
interp alias {} a+ {} punk::console::code_a+
interp alias {} a= {} punk::console::code_a
interp alias {} a {} punk::console::code_a
interp alias {} a? {} punk::console::code_a?

19
src/bootsupport/modules/punk/fileline-0.1.0.tm

@ -318,7 +318,7 @@ namespace eval punk::fileline::class {
package require overtype
# will require punk::char and punk::ansi
if {"::punk::fileline::ansi::stripansi" ne [info commands ::punk::fileline::ansi::stripansi]} {
if {"::punk::fileline::ansi::ansistrip" ne [info commands ::punk::fileline::ansi::ansistrip]} {
namespace eval ::punk::fileline::ansi {
namespace import ::punk::ansi::*
}
@ -334,7 +334,7 @@ namespace eval punk::fileline::class {
} else {
set ::punk::fileline::ansi::enabled 0
}
if {"::punk::fileline::stripansi" ne [info commands ::punk::fileline::stripansi]} {
if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} {
proc ::punk::fileline::a {args} {
if {$::punk::fileline::ansi::enabled} {
tailcall ::punk::fileline::ansi::a {*}$args
@ -349,9 +349,9 @@ namespace eval punk::fileline::class {
return ""
}
}
proc ::punk::fileline::stripansi {str} {
proc ::punk::fileline::ansistrip {str} {
if {$::punk::fileline::ansi::enabled} {
tailcall ::punk::fileline::ansi::stripansi $str
tailcall ::punk::fileline::ansi::ansistrip $str
} else {
return $str
}
@ -560,7 +560,7 @@ namespace eval punk::fileline::class {
set title_line "Line"
#todo - use punk::char for unicode support of wide chars etc?
set widest_linenum [tcl::mathfunc::max {*}[lmap v [concat [list $title_linenum] $linenums] {string length $v}]]
set widest_marker [tcl::mathfunc::max {*}[lmap v [concat [list $title_marker] $markers] {string length [stripansi $v]}]]
set widest_marker [tcl::mathfunc::max {*}[lmap v [concat [list $title_marker] $markers] {string length [ansistrip $v]}]]
set widest_status [expr {max([string length $opt_cmark], [string length $opt_tmark])}]
set widest_line [tcl::mathfunc::max {*}[lmap v [concat [list $title_line] $lines] {string length $v}]]
foreach row $result_list {
@ -1259,18 +1259,17 @@ namespace eval punk::fileline {
#[para]The encoding used is as specified in the -encoding option - or from the Byte Order Mark (bom) at the beginning of the data
#[para]For Tcl 8.6 - encodings such as utf-16le may not be available - so the bytes are swapped appropriately depending on the platform byteOrder and encoding 'unicode' is used.
#[para]encoding defaults to utf-8 if no -encoding specified and no BOM was found
#[para]Specify -encoding binary to perform no encoding conversion
#[para]Whether -encoding was specified or not - by default the BOM characters are not retained in the line-data
#[para]If -includebom 1 is specified - the bom will be retained in the stored chunk and the data for line 1, but will undergo the same encoding transformation as the rest of the data
#[para]The get_bomid method of the returned object will contain an identifier for any BOM encountered.
#[para] e.g utf-8,utf-16be, utf-16le, utf-32be, utf32-le, SCSU, BOCU-1,GB18030, UTF-EBCDIC, utf-1, utf-7
#[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes (binary translation)
#[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes of whatever encoding that is.
#[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data.
#[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding binary if this isn't suitable and you need to do your own processing of the raw data.
#[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes.
set argument_specification {
-file -default {} -type existingfile
-translation -default binary
-translation -default iso8859-1
-encoding -default "\uFFFF"
-includebom -default 0
*values -min 0 -max 1
@ -1712,7 +1711,7 @@ namespace eval punk::fileline::ansi {
#*** !doctools
#[call [fun ansi::a]]
#[call [fun ansi::a+]]
#[call [fun ansi::stripansi]]
#[call [fun ansi::ansistrip]]
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::fileline::ansi ---}]

970
src/bootsupport/modules/punk/lib-0.1.1.tm

File diff suppressed because it is too large Load Diff

24
src/bootsupport/modules/punk/mix/base-0.1.tm

@ -351,8 +351,14 @@ namespace eval punk::mix::base {
continue
}
set testfolder [file join $candidate src $sub]
set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm]
if {[llength $tmfiles]} {
#ensure that if src/modules exists - it is always included even if empty
if {[string tolower $sub] eq "modules"} {
lappend tm_folders $testfolder
continue
}
#set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm]
#set podfolders [glob -nocomplain -dir $testfolder -type d -tail #modpod-*]
if {[llength [glob -nocomplain -dir $testfolder -type f -tail *.tm]] || [llength [glob -nocomplain -dir $testfolder -type d -tail #modpod-*]]} {
lappend tm_folders $testfolder
}
}
@ -428,9 +434,10 @@ namespace eval punk::mix::base {
}
#crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?)
# - try builtin zlib crc instead?
#sha1 is performant - and this is not being used in a cryptographic or adversarial context - so performance and practical unlikelihood of accidental collisions should be the main consideration.
#adler32 is fastest for some larger files of a few MB but slower on small files (possibly due to Tcl-based file load?)
#sha1 as at 2023 seems a good default
#sha1 as at 2023 seems a reasonable default
proc cksum_algorithms {} {
variable sha3_implementation
#sha2 is an alias for sha256
@ -459,10 +466,16 @@ namespace eval punk::mix::base {
#adler32 via file-slurp
proc cksum_adler32_file {filename} {
package require zlib; #should be builtin anyway
set data [punk::mix::util::fcat -translation binary $filename]
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename]
#set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names
zlib adler32 $data
}
#zlib crc vie file-slurp
proc cksum_crc_file {filename} {
package require zlib
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename]
zlib crc $data
}
#required to be able to accept relative paths
@ -614,6 +627,9 @@ namespace eval punk::mix::base {
package require cksum ;#tcllib
set cksum_command [list crc::cksum -format 0x%X -file]
}
crc {
set cksum_command [list cksum_crc_file]
}
adler32 {
set cksum_command [list cksum_adler32_file]
}

252
src/modules/punk/mix/cli-0.3.tm → src/bootsupport/modules/punk/mix/cli-0.3.1.tm

@ -7,7 +7,7 @@
# (C) 2023
#
# @@ Meta Begin
# Application punk::mix::cli 0.3
# Application punk::mix::cli 0.3.1
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -18,6 +18,7 @@
## Requirements
##e.g package require frobz
package require punk::repo
package require punk::ansi
package require punkcheck ;#checksum and/or timestamp records
@ -202,7 +203,8 @@ namespace eval punk::mix::cli {
proc module_types {} {
#first in list is default for unspecified -type when creating new module
return [list plain tarjar zipkit]
#return [list plain tarjar zipkit]
return [list plain tarjar zip]
}
proc validate_modulename {modulename args} {
@ -401,7 +403,7 @@ namespace eval punk::mix::cli {
proc build_modules_from_source_to_base {srcdir basedir args} {
set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders we don't want to search in.
set antidir [list "#*" "_build" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders (at any level) we don't want to search in or copy.
set defaults [list\
-installer punk::mix::cli::build_modules_from_source_to_base\
-call-depth-internal 0\
@ -409,6 +411,7 @@ namespace eval punk::mix::cli {
-subdirlist {}\
-punkcheck_eventobj "\uFFFF"\
-glob *.tm\
-podglob #modpod-*\
]
set opts [dict merge $defaults $args]
@ -420,6 +423,7 @@ namespace eval punk::mix::cli {
set subdirlist [dict get $opts -subdirlist]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set fileglob [dict get $opts -glob]
set podglob [dict get $opts -podglob]
if {![string match "*.tm" $fileglob]} {
error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules."
}
@ -475,23 +479,213 @@ namespace eval punk::mix::cli {
#----------------------------------------
set process_modules [dict create]
#put pods first in processing order
set src_pods [glob -nocomplain -dir $current_source_dir -type d -tail $podglob]
foreach podpath $src_pods {
dict set process_modules $podpath [dict create -type pod]
}
set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob]
foreach modulepath $src_modules {
dict set process_modules $modulepath [dict create -type file]
}
set did_skip 0 ;#flag for stdout/stderr formatting only
foreach m $src_modules {
dict for {modpath modinfo} $process_modules {
set modtype [dict get $modinfo -type]
set is_interesting 0
if {[string match "foobar" $current_source_dir]} {
set is_interesting 1
}
if {$is_interesting} {
puts "build_modules_from_source_to_base >>> module $current_source_dir/$m"
puts "build_modules_from_source_to_base >>> module $current_source_dir/$modpath"
}
set fileparts [split [file rootname $modpath] -]
#set tmfile_versionsegment [lindex $fileparts end]
lassign [split_modulename_version $modpath] basename tmfile_versionsegment
if {$tmfile_versionsegment eq ""} {
#split_modulename_version version part will be empty if not valid tcl version
#last segment doesn't look even slightly versiony - fail.
puts stderr "ERROR: Unable to confirm file $current_source_dir/$modpath is a reasonably versioned .tm module - ABORTING."
exit 1
}
set fileparts [split [file rootname $m] -]
set tmfile_versionsegment [lindex $fileparts end]
switch -- $modtype {
pod {
#basename still contains leading #modpod-
if {[string match #modpod-* $basename]} {
set basename [string range $basename 8 end]
} else {
error "build_modules_from_source_to_base, pod, unexpected basename $basename" ;#shouldn't be possible with default podglob - review - why is podglob configurable?
}
set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use)
if {$tmfile_versionsegment eq $magicversion} {
#rebuild the .tm from the #tarjar
set basename [join [lrange $fileparts 0 end-1] -]
set versionfiledata ""
if {![file exists $versionfile]} {
puts stderr "\nWARNING: Missing buildversion text file: $versionfile"
puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n"
set module_build_version "0.1"
} else {
set fd [open $versionfile r]
set versionfiledata [read $fd]; close $fd
set ln0 [lindex [split $versionfiledata \n] 0]
set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r]
if {![util::is_valid_tm_version $ln0]} {
puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file"
exit 3
}
set module_build_version $ln0
}
} else {
set module_build_version $tmfile_versionsegment
}
set buildfolder $current_source_dir/_build
file mkdir $buildfolder
# -- ---
set config [dict create\
-glob *\
-max_depth 100\
]
# -max_depth -1 for no limit
set build_installername pods_in_$current_source_dir
set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck]
$build_installer set_source_target $current_source_dir/$modpath $buildfolder
set build_event [$build_installer start_event $config]
# -- ---
set podtree_copy $buildfolder/#modpod-$basename-$module_build_version
set modulefile $buildfolder/$basename-$module_build_version.tm
$build_event targetset_init INSTALL $podtree_copy
$build_event targetset_addsource $current_source_dir/$modpath
if {$tmfile_versionsegment eq $magicversion} {
$build_event targetset_addsource $versionfile
}
if {\
[llength [dict get [$build_event targetset_source_changes] changed]]\
|| [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\
} {
$build_event targetset_started
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n}
set delete_failed 0
if {[file exists $buildfolder/]} {
puts stderr "deleting existing _build copy at $podtree_copy"
if {[catch {
file delete -force $podtree_copy
} errMsg]} {
puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]"
set delete_failed 1
}
}
if {!$delete_failed} {
puts stdout "copying.."
puts stdout "$current_source_dir/$modpath"
puts stdout "to:"
puts stdout "$podtree_copy"
file copy $current_source_dir/$modpath $podtree_copy
if {$tmfile_versionsegment eq $magicversion} {
set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm
if {[file exists $tmfile]} {
set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm
file rename $tmfile $newname
set tmfile $newname
}
set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd
set data [string map [list $magicversion $module_build_version] $data]
set fdout [open $tmfile w]
fconfigure $fdout -translation binary
puts -nonewline $fdout $data
close $fdout
}
#delete and regenerate zip and modpod stubbed zip
set had_error 0
set notes [list]
if {[catch {
file delete $buildfolder/$basename-$module_build_version.zip
} err] } {
set had_error 1
lappend notes "zip_delete_failed"
}
if {[catch {
file delete $buildfolder/$basename-$module_build_version.tm
} err]} {
set had_error 1
lappend notes "tm_delete_failed"
}
#create ordinary zip file without using external executable
package require punk::zip
set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate)
if 0 {
#use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise
punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile *
#punk::zip::mkzip stores permissions - (unix style) which confuses zipfs when reading - it misidentifies dirs as files
}
#zipfs mkzip does exactly what we need anyway in this case
set wd [pwd]
cd $buildfolder
puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version"
zipfs mkzip $zipfile #modpod-$basename-$module_build_version
cd $wd
package require modpod
modpod::lib::make_zip_modpod $zipfile $modulefile
if {$had_error} {
$build_event targetset_end FAILED -note [join $notes ,]
} else {
# -- ----------
$build_event targetset_end OK
# -- ----------
}
} else {
$build_event targetset_end FAILED -note "could not delete $podtree_copy"
}
} else {
puts -nonewline stderr "."
set did_skip 1
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record]
$build_event targetset_end SKIPPED
}
$build_event destroy
$build_installer destroy
$event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm
$event targetset_addsource $modulefile
if {\
[llength [dict get [$event targetset_source_changes] changed]]\
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\
} {
$event targetset_started
# -- --- --- --- --- ---
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n}
lappend module_list $modulefile
file copy -force $modulefile $target_module_dir
puts stderr "Copied zip modpod module $modulefile to $target_module_dir"
# -- --- --- --- --- ---
$event targetset_end OK -note "zip modpod"
} else {
puts -nonewline stderr "."
set did_skip 1
if {$is_interesting} {
puts stderr "$modulefile [$event targetset_source_changes]"
}
$event targetset_end SKIPPED
}
}
tarjar {
#basename may still contain #tarjar-
#to be obsoleted - update modpod to (optionally) use vfs::tar
}
file {
set m $modpath
if {$tmfile_versionsegment eq $magicversion} {
#set basename [join [lrange $fileparts 0 end-1] -]
set versionfile $current_source_dir/$basename-buildversion.txt
set versionfiledata ""
if {![file exists $versionfile]} {
@ -512,8 +706,7 @@ namespace eval punk::mix::cli {
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} {
#TODO
file mkdir $buildfolder
#rebuild the .tm from the #tarjar
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} {
@ -521,20 +714,24 @@ namespace eval punk::mix::cli {
}
#REVIEW - should be in same structure/depth as $target_module_dir in _build?
set tmfile $basedir/_build/$basename-$module_build_version.tm
file mkdir $basedir/_build
file delete -force $basedir/_build/#tarjar-$basename-$module_build_version
#TODO
set buildfolder $current_sourcedir/_build
file mkdir $buildfolder
set tmfile $buildfolder/$basename-$module_build_version.tm
file delete -force $buildfolder/#tarjar-$basename-$module_build_version
file delete -force $tmfile
file copy -force $current_source_dir/#tarjar-$basename-$magicversion $basedir/_build/#tarjar-$basename-$module_build_version
file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version
#
#bsdtar doesn't seem to work.. or I haven't worked out the right options?
#exec tar -cvf $basedir/_build/$basename-$module_build_version.tm $basedir/_build/#tarjar-$basename-$module_build_version
#exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version
package require tar
tar::create $tmfile $basedir/_build/#tarjar-$basename-$module_build_version
tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version
if {![file exists $tmfile]} {
puts stdout "ERROR: Failed to build tarjar file $tmfile"
puts stdout "ERROR: failed to build tarjar file $tmfile"
exit 4
}
#copy the file?
@ -606,14 +803,6 @@ namespace eval punk::mix::cli {
continue
}
if {![util::is_valid_tm_version $tmfile_versionsegment]} {
#last segment doesn't look even slightly versiony - fail.
puts stderr "ERROR: Unable to confirm file $current_source_dir/$m is a reasonably versioned .tm module - ABORTING."
exit 1
}
##------------------------------
##
#set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m]
@ -625,7 +814,6 @@ namespace eval punk::mix::cli {
## -- --- --- --- --- ---
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]]
#set changed_list [dict get $changed_unchanged changed]
#----------
$event targetset_init INSTALL $target_module_dir/$m
$event targetset_addsource $current_source_dir/$m
@ -653,8 +841,11 @@ namespace eval punk::mix::cli {
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record]
$event targetset_end SKIPPED
}
}
}
} ;#end dict for {modpath modinfo} $process_modules
if {$CALLDEPTH >= $max_depth} {
set subdirs [list]
} else {
@ -680,6 +871,7 @@ namespace eval punk::mix::cli {
-subdirlist [list {*}$subdirlist $d]\
-punkcheck_eventobj $event\
-glob $fileglob\
-podglob $podglob\
]
}
if {$did_skip} {
@ -931,6 +1123,6 @@ namespace eval punk::mix::cli {
## Ready
package provide punk::mix::cli [namespace eval punk::mix::cli {
variable version
set version 0.3
set version 0.3.1
}]
return

248
src/bootsupport/modules/punk/mix/cli-0.3.tm

@ -18,6 +18,7 @@
## Requirements
##e.g package require frobz
package require punk::repo
package require punk::ansi
package require punkcheck ;#checksum and/or timestamp records
@ -202,7 +203,8 @@ namespace eval punk::mix::cli {
proc module_types {} {
#first in list is default for unspecified -type when creating new module
return [list plain tarjar zipkit]
#return [list plain tarjar zipkit]
return [list plain tarjar zip]
}
proc validate_modulename {modulename args} {
@ -401,7 +403,7 @@ namespace eval punk::mix::cli {
proc build_modules_from_source_to_base {srcdir basedir args} {
set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders we don't want to search in.
set antidir [list "#*" "_build" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders (at any level) we don't want to search in or copy.
set defaults [list\
-installer punk::mix::cli::build_modules_from_source_to_base\
-call-depth-internal 0\
@ -409,6 +411,7 @@ namespace eval punk::mix::cli {
-subdirlist {}\
-punkcheck_eventobj "\uFFFF"\
-glob *.tm\
-podglob #modpod-*\
]
set opts [dict merge $defaults $args]
@ -420,6 +423,7 @@ namespace eval punk::mix::cli {
set subdirlist [dict get $opts -subdirlist]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set fileglob [dict get $opts -glob]
set podglob [dict get $opts -podglob]
if {![string match "*.tm" $fileglob]} {
error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules."
}
@ -475,23 +479,213 @@ namespace eval punk::mix::cli {
#----------------------------------------
set process_modules [dict create]
#put pods first in processing order
set src_pods [glob -nocomplain -dir $current_source_dir -type d -tail $podglob]
foreach podpath $src_pods {
dict set process_modules $podpath [dict create -type pod]
}
set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob]
foreach modulepath $src_modules {
dict set process_modules $modulepath [dict create -type file]
}
set did_skip 0 ;#flag for stdout/stderr formatting only
foreach m $src_modules {
dict for {modpath modinfo} $process_modules {
set modtype [dict get $modinfo -type]
set is_interesting 0
if {[string match "foobar" $current_source_dir]} {
set is_interesting 1
}
if {$is_interesting} {
puts "build_modules_from_source_to_base >>> module $current_source_dir/$m"
puts "build_modules_from_source_to_base >>> module $current_source_dir/$modpath"
}
set fileparts [split [file rootname $modpath] -]
#set tmfile_versionsegment [lindex $fileparts end]
lassign [split_modulename_version $modpath] basename tmfile_versionsegment
if {$tmfile_versionsegment eq ""} {
#split_modulename_version version part will be empty if not valid tcl version
#last segment doesn't look even slightly versiony - fail.
puts stderr "ERROR: Unable to confirm file $current_source_dir/$modpath is a reasonably versioned .tm module - ABORTING."
exit 1
}
set fileparts [split [file rootname $m] -]
set tmfile_versionsegment [lindex $fileparts end]
switch -- $modtype {
pod {
#basename still contains leading #modpod-
if {[string match #modpod-* $basename]} {
set basename [string range $basename 8 end]
} else {
error "build_modules_from_source_to_base, pod, unexpected basename $basename" ;#shouldn't be possible with default podglob - review - why is podglob configurable?
}
set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use)
if {$tmfile_versionsegment eq $magicversion} {
#rebuild the .tm from the #tarjar
set basename [join [lrange $fileparts 0 end-1] -]
set versionfiledata ""
if {![file exists $versionfile]} {
puts stderr "\nWARNING: Missing buildversion text file: $versionfile"
puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n"
set module_build_version "0.1"
} else {
set fd [open $versionfile r]
set versionfiledata [read $fd]; close $fd
set ln0 [lindex [split $versionfiledata \n] 0]
set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r]
if {![util::is_valid_tm_version $ln0]} {
puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file"
exit 3
}
set module_build_version $ln0
}
} else {
set module_build_version $tmfile_versionsegment
}
set buildfolder $current_source_dir/_build
file mkdir $buildfolder
# -- ---
set config [dict create\
-glob *\
-max_depth 100\
]
# -max_depth -1 for no limit
set build_installername pods_in_$current_source_dir
set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck]
$build_installer set_source_target $current_source_dir/$modpath $buildfolder
set build_event [$build_installer start_event $config]
# -- ---
set podtree_copy $buildfolder/#modpod-$basename-$module_build_version
set modulefile $buildfolder/$basename-$module_build_version.tm
$build_event targetset_init INSTALL $podtree_copy
$build_event targetset_addsource $current_source_dir/$modpath
if {$tmfile_versionsegment eq $magicversion} {
$build_event targetset_addsource $versionfile
}
if {\
[llength [dict get [$build_event targetset_source_changes] changed]]\
|| [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\
} {
$build_event targetset_started
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n}
set delete_failed 0
if {[file exists $buildfolder/]} {
puts stderr "deleting existing _build copy at $podtree_copy"
if {[catch {
file delete -force $podtree_copy
} errMsg]} {
puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]"
set delete_failed 1
}
}
if {!$delete_failed} {
puts stdout "copying.."
puts stdout "$current_source_dir/$modpath"
puts stdout "to:"
puts stdout "$podtree_copy"
file copy $current_source_dir/$modpath $podtree_copy
if {$tmfile_versionsegment eq $magicversion} {
set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm
if {[file exists $tmfile]} {
set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm
file rename $tmfile $newname
set tmfile $newname
}
set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd
set data [string map [list $magicversion $module_build_version] $data]
set fdout [open $tmfile w]
fconfigure $fdout -translation binary
puts -nonewline $fdout $data
close $fdout
}
#delete and regenerate zip and modpod stubbed zip
set had_error 0
set notes [list]
if {[catch {
file delete $buildfolder/$basename-$module_build_version.zip
} err] } {
set had_error 1
lappend notes "zip_delete_failed"
}
if {[catch {
file delete $buildfolder/$basename-$module_build_version.tm
} err]} {
set had_error 1
lappend notes "tm_delete_failed"
}
#create ordinary zip file without using external executable
package require punk::zip
set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate)
if 0 {
#use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise
punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile *
#punk::zip::mkzip stores permissions - (unix style) which confuses zipfs when reading - it misidentifies dirs as files
}
#zipfs mkzip does exactly what we need anyway in this case
set wd [pwd]
cd $buildfolder
puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version"
zipfs mkzip $zipfile #modpod-$basename-$module_build_version
cd $wd
package require modpod
modpod::lib::make_zip_modpod $zipfile $modulefile
if {$had_error} {
$build_event targetset_end FAILED -note [join $notes ,]
} else {
# -- ----------
$build_event targetset_end OK
# -- ----------
}
} else {
$build_event targetset_end FAILED -note "could not delete $podtree_copy"
}
} else {
puts -nonewline stderr "."
set did_skip 1
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record]
$build_event targetset_end SKIPPED
}
$build_event destroy
$build_installer destroy
$event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm
$event targetset_addsource $modulefile
if {\
[llength [dict get [$event targetset_source_changes] changed]]\
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\
} {
$event targetset_started
# -- --- --- --- --- ---
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n}
lappend module_list $modulefile
file copy -force $modulefile $target_module_dir
puts stderr "Copied zip modpod module $modulefile to $target_module_dir"
# -- --- --- --- --- ---
$event targetset_end OK -note "zip modpod"
} else {
puts -nonewline stderr "."
set did_skip 1
if {$is_interesting} {
puts stderr "$modulefile [$event targetset_source_changes]"
}
$event targetset_end SKIPPED
}
}
tarjar {
#basename may still contain #tarjar-
#to be obsoleted - update modpod to (optionally) use vfs::tar
}
file {
set m $modpath
if {$tmfile_versionsegment eq $magicversion} {
#set basename [join [lrange $fileparts 0 end-1] -]
set versionfile $current_source_dir/$basename-buildversion.txt
set versionfiledata ""
if {![file exists $versionfile]} {
@ -512,8 +706,7 @@ namespace eval punk::mix::cli {
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} {
#TODO
file mkdir $buildfolder
#rebuild the .tm from the #tarjar
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} {
@ -521,20 +714,24 @@ namespace eval punk::mix::cli {
}
#REVIEW - should be in same structure/depth as $target_module_dir in _build?
set tmfile $basedir/_build/$basename-$module_build_version.tm
file mkdir $basedir/_build
file delete -force $basedir/_build/#tarjar-$basename-$module_build_version
#TODO
set buildfolder $current_sourcedir/_build
file mkdir $buildfolder
set tmfile $buildfolder/$basename-$module_build_version.tm
file delete -force $buildfolder/#tarjar-$basename-$module_build_version
file delete -force $tmfile
file copy -force $current_source_dir/#tarjar-$basename-$magicversion $basedir/_build/#tarjar-$basename-$module_build_version
file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version
#
#bsdtar doesn't seem to work.. or I haven't worked out the right options?
#exec tar -cvf $basedir/_build/$basename-$module_build_version.tm $basedir/_build/#tarjar-$basename-$module_build_version
#exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version
package require tar
tar::create $tmfile $basedir/_build/#tarjar-$basename-$module_build_version
tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version
if {![file exists $tmfile]} {
puts stdout "ERROR: Failed to build tarjar file $tmfile"
puts stdout "ERROR: failed to build tarjar file $tmfile"
exit 4
}
#copy the file?
@ -606,14 +803,6 @@ namespace eval punk::mix::cli {
continue
}
if {![util::is_valid_tm_version $tmfile_versionsegment]} {
#last segment doesn't look even slightly versiony - fail.
puts stderr "ERROR: Unable to confirm file $current_source_dir/$m is a reasonably versioned .tm module - ABORTING."
exit 1
}
##------------------------------
##
#set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m]
@ -625,7 +814,6 @@ namespace eval punk::mix::cli {
## -- --- --- --- --- ---
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]]
#set changed_list [dict get $changed_unchanged changed]
#----------
$event targetset_init INSTALL $target_module_dir/$m
$event targetset_addsource $current_source_dir/$m
@ -653,8 +841,11 @@ namespace eval punk::mix::cli {
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record]
$event targetset_end SKIPPED
}
}
}
} ;#end dict for {modpath modinfo} $process_modules
if {$CALLDEPTH >= $max_depth} {
set subdirs [list]
} else {
@ -680,6 +871,7 @@ namespace eval punk::mix::cli {
-subdirlist [list {*}$subdirlist $d]\
-punkcheck_eventobj $event\
-glob $fileglob\
-podglob $podglob\
]
}
if {$did_skip} {

4
src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm

@ -31,7 +31,7 @@ namespace eval punk::mix::commandset::debug {
set out ""
puts stdout "find_repos output:"
set pathinfo [punk::repo::find_repos [pwd]]
pdict $pathinfo
pdict pathinfo
set projectdir [dict get $pathinfo closest]
set modulefolders [lib::find_source_module_paths $projectdir]
@ -39,7 +39,7 @@ namespace eval punk::mix::commandset::debug {
set template_base_dict [punk::mix::base::lib::get_template_basefolders]
puts stdout "get_template_basefolders output:"
pdict $template_base_dict
pdict template_base_dict */*
return
}

50
src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm

@ -159,7 +159,7 @@ namespace eval punk::mix::commandset::module {
#set opts [dict merge $defaults $args]
#todo - review compatibility between -template and -type
#-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl)
#-type is the wrapping technology e.g 'plain' for none or tarjar or zip (modpod) etc (consider also snappy/snappy-tcl)
#-template may be a folder - but only if the selected -type suports it
@ -293,6 +293,7 @@ namespace eval punk::mix::commandset::module {
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_quiet [dict get $opts -quiet]
set opt_force [dict get $opts -force]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
@ -378,13 +379,39 @@ namespace eval punk::mix::commandset::module {
}
set template_filedata [string map $strmap $template_filedata]
set modulefile $modulefolder/${moduletail}-$infile_version.tm
if {[file exists $modulefile]} {
set errmsg "module.new error: module file $modulefile already exists - aborting"
if {[string match "*$magicversion*" $modulefile]} {
set tmfile $modulefolder/${moduletail}-$infile_version.tm
set podfile $modulefolder/#modpod-$moduletail-$infile_version/$moduletail-$infile_version.tm
set has_tm [file exists $tmfile]
set has_pod [file exists $podfile]
if {$has_tm && $has_pos} {
#invalid configuration - bomb out
error "module.new error: Invalid target configuration found. module folder has both a .tm file $tmfile and a modpod file $podfile. Please delete one of them before trying again."
}
if {$opt_type eq "plain"} {
set modulefile $tmfile
} else {
set modulefile $podfile
}
if {$has_tm || $has_pod} {
if {!$opt_force} {
if {$has_tm} {
set errmsg "module.new error: module file $tmfile already exists - aborting"
} else {
set errmsg "module.new error: module file $podfile already exists - aborting"
}
if {[string match "*$magicversion*" $tmfile]} {
append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm"
}
error $errmsg
} else {
#review - prompt here vs caller?
#we are committed to overwriting/replacing if there was a pre-existing module of same version
if {$has_pod} {
file delete -force [file dirname $podfile]
} elseif {$has_tm} {
file delete -force $tmfile
}
}
}
@ -407,13 +434,20 @@ namespace eval punk::mix::commandset::module {
}
}
set existing_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm]
set existing_tm_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm]
#it shouldn't be possible to overmatch with the glob - because '-' is not valid in a Tcl module name
set existing_pod_versions [glob -nocomplain -dir $modulefolder -tails #modpod-$moduletail-*]
set existing_versions [concat $existing_tm_versions $existing_pod_versions]
if {[llength $existing_versions]} {
set name_version_pairs [list]
lappend name_version_pairs [list $moduletail $infile_version]
foreach existing $existing_versions {
lappend name_version_pairs [punk::mix::cli::lib::split_modulename_version $existing] ;# .tm is stripped and ignored
lassign [punk::mix::cli::lib::split_modulename_version $existing] namepart version ;# .tm is stripped and ignored
if {[string match #modpod-* $namepart]} {
set namepart [string range $namepart 8 end]
}
lappend name_version_pairs [list $namepart $version]
}
set name_version_pairs [lsort -command {package vcompare} -index 1 $name_version_pairs] ;#while plain lsort will often work with versions - it can get order wrong with some - so use package vcompare
if {[lindex $name_version_pairs end] ne [list $moduletail $infile_version]} {
@ -436,6 +470,8 @@ namespace eval punk::mix::commandset::module {
if {!$opt_quiet} {
puts stdout "Creating $modulefile from template $moduletemplate"
}
file mkdir [file dirname $modulefile]
set fd [open $modulefile w]
fconfigure $fd -translation binary
puts -nonewline $fd $template_filedata

26
src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm

@ -320,6 +320,8 @@ namespace eval punk::mix::commandset::project {
puts stderr "-force 1 or -update 1 not specified - aborting"
return
}
#review
set fossil_repo_file $repodb_folder/$projectname.fossil
}
if {$fossil_repo_file eq ""} {
@ -415,12 +417,30 @@ namespace eval punk::mix::commandset::project {
if {[file exists $projectdir/src/modules]} {
foreach m $opt_modules {
if {![file exists $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm]} {
#check if mod-ver.tm file or #modpod-mod-ver folder exist
set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm
set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm
set has_tm [file exists $tmfile]
set has_pod [file exists $podfile]
#puts stderr "=====> has_tm: $has_tm has_pod: $has_pod"
if {!$has_tm && !$has_pod} {
#todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc
punk::mix::commandset::module::new $m -project $projectname -type $opt_type
punk::mix::commandset::module::new -project $projectname -type $opt_type $m
} else {
#we should rarely if ever want to force any src/modules to be overwritten
if {$opt_force} {
punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force 1
if {$has_pod} {
set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"]
set overwrite_type zip
} else {
set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"]
set overwrite_type $opt_type
}
if {[string tolower $answer] eq "y"} {
#REVIEW - all pods zip - for now
punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m
}
}
}
}

102
src/bootsupport/modules/punk/mix/templates/layouts/project/src/make.tcl

@ -13,7 +13,7 @@ namespace eval ::punkmake {
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list]
variable non_help_flags [list -k]
variable help_flags [list -help --help /?]
variable known_commands [list project get-project-info shell bootsupport]
variable known_commands [list project get-project-info shell vendor bootsupport]
}
if {"::try" ni [info commands ::try]} {
puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting"
@ -134,6 +134,8 @@ proc punkmake_gethelp {args} {
append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n \n
append h " $scriptname bootsupport" \n
append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n \n
append h " $scriptname vendor" \n
append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n
append h " $scriptname get-project-info" \n
append h " - show the name and base folder of the project to be built" \n
append h "" \n
@ -251,6 +253,100 @@ if {$::punkmake::command eq "shell"} {
exit 1
}
if {$::punkmake::command eq "vendor"} {
puts "projectroot: $projectroot"
puts "script: [info script]"
#puts "-- [tcl::tm::list] --"
puts stdout "Updating vendor modules"
proc vendor_localupdate {projectroot} {
set local_modules [list]
set git_modules [list]
set fossil_modules [list]
#todo vendor/lib ?
set vendor_config $projectroot/src/vendormodules/include_modules.config
if {[file exists $vendor_config]} {
set targetroot $projectroot/src/vendormodules/modules
source $vendor_config ;#populate $local_modules $git_modules $fossil_modules with project-specific list
if {![llength $local_modules]} {
puts stderr "No local vendor modules configured for updating (config file: $vendor_config)"
} else {
if {[catch {
#----------
set vendor_installer [punkcheck::installtrack new make.tcl $projectroot/src/vendormodules/.punkcheck]
$vendor_installer set_source_target $projectroot $projectroot/src/vendormodules
set installation_event [$vendor_installer start_event {-make_step vendor}]
#----------
} errM]} {
puts stderr "Unable to use punkcheck for vendor update. Error: $errM"
set installation_event ""
}
foreach {relpath module} $local_modules {
set module [string trim $module :]
set module_subpath [string map {:: /} [namespace qualifiers $module]]
set srclocation [file join $projectroot $relpath $module_subpath]
#puts stdout "$relpath $module $module_subpath $srclocation"
set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*]
#lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1
if {![llength $pkgmatches]} {
puts stderr "Missing source for vendor module $module - not found in $srclocation"
continue
}
set latestfile [lindex $pkgmatches 0]
set latestver [lindex [split [file rootname $latestfile] -] 1]
foreach m $pkgmatches {
lassign [split [file rootname $m] -] _pkg ver
#puts "comparing $ver vs $latestver"
if {[package vcompare $ver $latestver] == 1} {
set latestver $ver
set latestfile $m
}
}
set srcfile [file join $srclocation $latestfile]
set tgtfile [file join $targetroot $module_subpath $latestfile]
if {$installation_event ne ""} {
#----------
$installation_event targetset_init INSTALL $tgtfile
$installation_event targetset_addsource $srcfile
#----------
if {\
[llength [dict get [$installation_event targetset_source_changes] changed]]\
|| [llength [$installation_event get_targets_exist]] < [llength [$installation_event get_targets]]\
} {
file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists
$installation_event targetset_started
# -- --- --- --- --- ---
puts "VENDOR update: $srcfile -> $tgtfile"
if {[catch {
file copy -force $srcfile $tgtfile
} errM]} {
$installation_event targetset_end FAILED
} else {
$installation_event targetset_end OK
}
# -- --- --- --- --- ---
} else {
puts -nonewline stderr "."
$installation_event targetset_end SKIPPED
}
$installation_event end
} else {
file copy -force $srcfile $tgtfile
}
}
}
} else {
puts stderr "No config at $vendor_config - nothing configured to update"
}
}
puts stdout " vendor package update done "
flush stderr
flush stdout
::exit 0
}
if {$::punkmake::command eq "bootsupport"} {
puts "projectroot: $projectroot"
puts "script: [info script]"
@ -275,7 +371,7 @@ if {$::punkmake::command eq "bootsupport"} {
set boot_event [$boot_installer start_event {-make_step bootsupport}]
#----------
} errM]} {
puts stderr "Unable to use punkcheck for bootsupport error: $errM"
puts stderr "Unable to use punkcheck for bootsupport. Error: $errM"
set boot_event ""
}
@ -441,7 +537,7 @@ if {[file exists $sourcefolder/vendorlib]} {
if {[file exists $sourcefolder/vendormodules]} {
#install .tm *and other files*
puts stdout "VENDORMODULES: copying from $sourcefolder/vendormodules to $target_modules_base (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md}]
set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
} else {
puts stderr "VENDORMODULES: No src/vendormodules folder found."

53
src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl

@ -0,0 +1,53 @@
apply {code {
set scriptpath [file normalize [info script]]
if {[string match "#modpod-loadscript*.tcl" [file tail $scriptpath]]} {
#jump up an extra dir level if we are within a #modpod-loadscript file.
set mypath [file dirname [file dirname $scriptpath]]
#expect to be in folder #modpod-<module>-<ver>
#Now we need to test if we are in a mounted folder vs an extracted folder
set container [file dirname $mypath]
if {[string match "#mounted-modpod-*" $container]} {
set mypath [file dirname $container]
}
set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #modpod-<module>-<ver>
} else {
set mypath [file dirname $scriptpath]
set modver [file root [file tail [info script]]]
}
set mysegs [file split $mypath]
set overhang [list]
foreach libpath [tcl::tm::list] {
set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & /
if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} {
#mypath is below libpath
set overhang [lrange $mysegs [llength $libsegs]+1 end]
break
}
}
lassign [split $modver -] moduletail version
set ns [join [concat $overhang $moduletail] ::]
#if {![catch {package require modpod}]} {
# ::modpod::disconnect [info script]
#}
package provide $ns $version
namespace eval $ns $code
} ::} {
#
# Module procs here, where current namespace is that of the module.
# Package version can, if needed, be accessed as [uplevel 1 {set version}]
# Last element of module name: [uplevel 1 {set moduletail}]
# Full module name: [uplevel 1 {set ns}]
#<modulecode>
#
#</modulecode>
#<sourcefiles>
#
#</sourcefiles>
#<loadfiles>
#
#</loadfiles>
}

2
src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/z

@ -0,0 +1,2 @@
#Do not remove the trailing ctrl-z character from this file


BIN
src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip

Binary file not shown.

7
src/bootsupport/modules/punk/mix/templates/utility/a b/tcltest.bat

@ -1,7 +0,0 @@
::lindex tcl;#\
@call tclsh "%~dp0%~n0.bat" %* & goto :eof
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl
puts stdout "script: [info script]"
puts stdout "argv: $::argc"
puts stdout "args: '$::argv'"

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

@ -1166,24 +1166,6 @@ tcl::namespace::eval punk::ns {
lappend allooclasses $cmd
}
}
if {[catch {
if {$cmd eq ""} {
#empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string.
set nsorigin [namespace origin ${location}::]
} elseif {[string match :* $cmd]} {
set nsorigin [nseval $location "::namespace origin $cmd"]
} else {
set nsorigin [namespace origin [nsjoin $location $cmd]]
}
} errM]} {
puts stderr "get_ns_dicts failed to determine origin of command '$cmd' adding to 'undetermined'"
puts stderr "error message: $errM"
lappend allundetermined $cmd
} else {
if {[nsprefix $nsorigin] ne $location} {
lappend allimported $cmd
}
}
}
default {
if {$ctype eq "imported"} {
@ -1242,6 +1224,25 @@ tcl::namespace::eval punk::ns {
}
}
#JMN
if {[catch {
if {$cmd eq ""} {
#empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string.
set nsorigin [namespace origin ${location}::]
} elseif {[string match :* $cmd]} {
set nsorigin [nseval $location "::namespace origin $cmd"]
} else {
set nsorigin [namespace origin [nsjoin $location $cmd]]
}
} errM]} {
puts stderr "get_ns_dicts failed to determine origin of command '$cmd' adding to 'undetermined'"
puts stderr "error message: $errM"
lappend allundetermined $cmd
} else {
if {[nsprefix $nsorigin] ne $location} {
lappend allimported $cmd
}
}
}
if {$glob ne "*"} {
set childtailmatches [lsearch -all -inline $childtails $glob]

3
src/bootsupport/modules/punk/path-0.1.0.tm

@ -217,7 +217,8 @@ namespace eval punk::path {
-directory -default "\uFFFF"
-call-depth-internal -default 0 -type integer
-antiglob_paths -default {}
*values -min 0 -max -1 -type string
*values -min 0 -max -1 -optional 1 -type string
tailglobs -multiple 1
} $args]
lassign [dict values $argd] opts values
set tailglobs [dict values $values]

9
src/bootsupport/modules/punk/repo-0.1.1.tm

@ -1447,6 +1447,7 @@ namespace eval punk::repo {
#Must accept empty prefix - which is effectively noop.
#MUCH faster version for absolute path prefix (pre-normalized)
#review - will error on file join if lrange returns empty list ie if prefix longer than path
proc path_strip_alreadynormalized_prefixdepth {path prefix} {
if {$prefix eq ""} {
return $path
@ -1488,11 +1489,11 @@ namespace eval punk::repo {
interp alias {} git_revision {} ::punk::repo::git_revision
interp alias {} gs {} git status -sb
interp alias {} gs {} shellrun::runconsole git status -sb
interp alias {} gr {} ::punk::repo::git_revision
interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console
interp alias {} glast {} git log -1 HEAD --stat
interp alias {} gconf {} git config --global -l
interp alias {} gl {} shellrun::runconsole git log --oneline --decorate ;#decorate so stdout consistent with what we see on console
interp alias {} glast {} shellrun::runconsole git log -1 HEAD --stat
interp alias {} gconf {} shellrun::runconsole git config --global -l
}
namespace eval punk::repo::lib {

6
src/bootsupport/modules/punkcheck-0.1.0.tm

@ -37,7 +37,7 @@ namespace eval punkcheck {
start_installer_event installfile_*
#antiglob_dir & antiglob_file entries match the pattern at any level - should not contain path separators
variable default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"]
variable default_antiglob_dir_core [list "#*" "_aside" "_build" ".git" ".fossil*"]
variable default_antiglob_file_core ""
proc uuid {} {
set has_twapi 0
@ -1196,7 +1196,7 @@ namespace eval punkcheck {
#and may be less error prone than doing slightly more opaue path manipulations at each recursion level to determine where we started
#For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one.
set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDPEPTH = 0
set max_depth [dict get $opts -max_depth]
set max_depth [dict get $opts -max_depth] ;# -1 for no limit
set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill
set fileglob [dict get $opts -glob]
set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting
@ -1598,7 +1598,7 @@ namespace eval punkcheck {
}
if {$CALLDEPTH >= $max_depth} {
if {$max_depth != -1 && $CALLDEPTH >= $max_depth} {
#don't process any more subdirs
set subdirs [list]
} else {

602
src/bootsupport/modules/textblock-0.1.1.tm

File diff suppressed because it is too large Load Diff

9
src/bootsupport/modules_tcl8/include_modules.config

@ -0,0 +1,9 @@
#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.
#each entry - base module
set bootsupport_modules [list\
modules_tcl8 thread\
]

253
src/make.tcl

@ -13,7 +13,7 @@ namespace eval ::punkmake {
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list]
variable non_help_flags [list -k]
variable help_flags [list -help --help /?]
variable known_commands [list project get-project-info shell bootsupport]
variable known_commands [list project get-project-info shell vendorupdate bootsupport]
}
if {"::try" ni [info commands ::try]} {
puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting"
@ -134,6 +134,8 @@ proc punkmake_gethelp {args} {
append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n \n
append h " $scriptname bootsupport" \n
append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n \n
append h " $scriptname vendorupdate" \n
append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n
append h " $scriptname get-project-info" \n
append h " - show the name and base folder of the project to be built" \n
append h "" \n
@ -251,6 +253,118 @@ if {$::punkmake::command eq "shell"} {
exit 1
}
if {$::punkmake::command eq "vendorupdate"} {
puts "projectroot: $projectroot"
puts "script: [info script]"
#puts "-- [tcl::tm::list] --"
puts stdout "Updating vendor modules in src folder"
proc vendor_localupdate {projectroot} {
set local_modules [list]
set git_modules [list]
set fossil_modules [list]
set sourcefolder $projectroot/src
#todo vendor/lib
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*]
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*]
lappend vendormodulefolders vendormodules
foreach vf $vendormodulefolders {
if {[file exists $sourcefolder/$vf]} {
lassign [split $vf _] _vm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set vendor_config $sourcefolder/vendormodules$which/include_modules.config
if {[file exists $vendor_config]} {
set targetroot $sourcefolder/vendormodules$which
source $vendor_config ;#populate $local_modules $git_modules $fossil_modules with project-specific list
if {![llength $local_modules]} {
puts stderr "src/vendormodules$which No local vendor modules configured for updating (config file: $vendor_config)"
} else {
if {[catch {
#----------
set vendor_installer [punkcheck::installtrack new make.tcl $sourcefolder/vendormodules$which/.punkcheck]
$vendor_installer set_source_target $projectroot $sourcefolder/vendormodules$which
set installation_event [$vendor_installer start_event {-make_step vendorupdate}]
#----------
} errM]} {
puts stderr "Unable to use punkcheck for vendormodules$which update. Error: $errM"
set installation_event ""
}
foreach {relpath module} $local_modules {
set module [string trim $module :]
set module_subpath [string map {:: /} [namespace qualifiers $module]]
set srclocation [file join $projectroot $relpath $module_subpath]
#puts stdout "$relpath $module $module_subpath $srclocation"
set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*]
#lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1
if {![llength $pkgmatches]} {
puts stderr "Missing source for vendor module $module - not found in $srclocation"
continue
}
set latestfile [lindex $pkgmatches 0]
set latestver [lindex [split [file rootname $latestfile] -] 1]
foreach m $pkgmatches {
lassign [split [file rootname $m] -] _pkg ver
#puts "comparing $ver vs $latestver"
if {[package vcompare $ver $latestver] == 1} {
set latestver $ver
set latestfile $m
}
}
set srcfile [file join $srclocation $latestfile]
set tgtfile [file join $targetroot $module_subpath $latestfile]
if {$installation_event ne ""} {
#----------
$installation_event targetset_init INSTALL $tgtfile
$installation_event targetset_addsource $srcfile
#----------
if {\
[llength [dict get [$installation_event targetset_source_changes] changed]]\
|| [llength [$installation_event get_targets_exist]] < [llength [$installation_event get_targets]]\
} {
file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists
$installation_event targetset_started
# -- --- --- --- --- ---
puts "VENDORMODULES$which update: $srcfile -> $tgtfile"
if {[catch {
file copy -force $srcfile $tgtfile
} errM]} {
$installation_event targetset_end FAILED
} else {
$installation_event targetset_end OK
}
# -- --- --- --- --- ---
} else {
puts -nonewline stderr "."
$installation_event targetset_end SKIPPED
}
$installation_event end
} else {
file copy -force $srcfile $tgtfile
}
}
}
} else {
puts stderr "No config at $vendor_config - nothing configured to update"
}
}
}
}
vendor_localupdate $projectroot
puts stdout " vendor package update done "
flush stderr
flush stdout
::exit 0
}
if {$::punkmake::command eq "bootsupport"} {
puts "projectroot: $projectroot"
puts "script: [info script]"
@ -258,14 +372,24 @@ if {$::punkmake::command eq "bootsupport"} {
puts stdout "Updating bootsupport from local files"
proc bootsupport_localupdate {projectroot} {
set bootsupport_modules [list]
set bootsupport_module_folders [list]
set bootsupport_config $projectroot/src/bootsupport/include_modules.config ;#
set bootsupport_modules [list] ;#variable populated by include_modules.config file - review
set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules_tcl*]
lappend bootmodulefolder modules
foreach bm $bootmodulefolders {
if {[file exists $sourcefolder/bootsupport/$bm]} {
lassign [split $bm _] _bm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;#
if {[file exists $bootsupport_config]} {
set targetroot $projectroot/src/bootsupport/modules
set targetroot $projectroot/src/bootsupport/modules$which
source $bootsupport_config ;#populate $bootsupport_modules with project-specific list
if {![llength $bootsupport_modules]} {
puts stderr "No local bootsupport modules configured for updating"
puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating"
} else {
if {[catch {
@ -314,7 +438,7 @@ if {$::punkmake::command eq "bootsupport"} {
file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists
$boot_event targetset_started
# -- --- --- --- --- ---
puts "BOOTSUPPORT update: $srcfile -> $tgtfile"
puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile"
if {[catch {
file copy -force $srcfile $tgtfile
} errM]} {
@ -339,36 +463,15 @@ if {$::punkmake::command eq "bootsupport"} {
}
}
if {[llength $bootsupport_module_folders] % 2 != 0} {
#todo - change include_modules.config structure to be line based? we have no way of verifying paired entries because we accept a flat list
puts stderr "WARNING - Skipping bootsupport_module_folders - list should be a list of base subpath pairs"
} else {
foreach {base subfolder} $bootsupport_module_folders {
#user should be careful not to include recursive/cyclic structures e.g module that has a folder which contains other modules from this project
#It will probably work somewhat.. but may make updates confusing.. or worse - start making deeper and deeper copies
set src [file join $projectroot $base $subfolder]
if {![file isdirectory $src]} {
puts stderr "bootsupport folder not found: $src"
continue
}
#subfolder is the common relative path - so don't include the base in the target path
set tgt [file join $targetroot $subfolder]
file mkdir $tgt
puts stdout "BOOTSUPPORT non_tm_files $src - copying to $tgt (if source file changed)"
set overwrite "installedsourcechanged-targets"
set resultdict [punkcheck::install_non_tm_files $src $tgt -installer make.tcl -overwrite $overwrite -punkcheck_folder $projectroot/src/bootsupport]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
}
}
}
}
bootsupport_localupdate $projectroot
#/modules/punk/mix/templates/layouts only applies if the project has it's own copy of the punk/mix modules. Generally this should only apply to the punkshell project itself.
#if this project has custom project layouts, and there is a bootsupport folder - update their bootsupport
set layout_bases [list\
$sourcefolder/project_layouts/custom/_project\
]
@ -381,16 +484,28 @@ if {$::punkmake::command eq "bootsupport"} {
set antipaths [list\
README.md\
]
set sourcemodules $projectroot/src/bootsupport/modules
set targetroot [file join $project_layout_base $layoutname/src/bootsupport/modules]
set boot_module_folders [glob -nocomplain -dir $projectroot/src/bootsupport/modules_tcl*]
lappend bootsupport_module_folders "modules"
foreach bm $bootsupport_module_folders {
if {[file exists $projectroot/src/bootsupport/$bm]} {
lassign [split $bm _] _bm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set sourcemodules $projectroot/src/bootsupport/modules$which
set targetroot [file join $project_layout_base $layoutname/src/bootsupport/modules$which]
file mkdir $targetroot
puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $sourcemodules to $targetroot (if source file changed)"
puts stdout "BOOTSUPPORT$which layouts/$layoutname: copying from $sourcemodules to $targetroot (if source file changed)"
set resultdict [punkcheck::install $sourcemodules $targetroot -overwrite installedsourcechanged-targets -antiglob_paths $antipaths]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
flush stdout
}
}
}
}
} else {
puts stderr "No layout base at $project_layout_base"
}
@ -412,15 +527,26 @@ if {$::punkmake::command ne "project"} {
exit 1
}
file mkdir $projectroot/lib ;#needs to exist
#only a single consolidated /modules folder used for target
set target_modules_base $projectroot/modules
file mkdir $target_modules_base
#external libs and modules first - and any supporting files - no 'building' required
if {[file exists $sourcefolder/vendorlib]} {
#install src vendor contents (from version controlled src folder) to base of project (same target folders as our own src/modules etc ie to paths that go on the auto_path and in tcl::tm::list)
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*]
lappend vendorlibfolders vendorlib
foreach lf $vendorlibfolders {
if {[file exists $sourcefolder/$lf]} {
lassign [split $lf _] _vm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set target_lib_folder $projectroot/lib$which
file mkdir $projectroot/lib$which
#exclude README.md from source folder - but only the root one
#-antiglob_paths takes relative patterns e.g
# */test.txt will only match test.txt exactly one level deep.
@ -430,21 +556,37 @@ if {[file exists $sourcefolder/vendorlib]} {
README.md\
]
puts stdout "VENDORLIB: copying from $sourcefolder/vendorlib to $projectroot/lib (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/vendorlib $projectroot/lib -overwrite installedsourcechanged-targets -antiglob_paths $antipaths]
puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
} else {
puts stderr "VENDORLIB: No src/vendorlib folder found."
}
}
if {![llength $vendorlibfolders]} {
puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found."
}
if {[file exists $sourcefolder/vendormodules]} {
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*]
lappend vendormodulefolders vendormodules
foreach vf $vendormodulefolders {
if {[file exists $sourcefolder/$vf]} {
lassign [split $vf _] _vm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set target_module_folder $projectroot/modules$which
file mkdir $target_module_folder
#install .tm *and other files*
puts stdout "VENDORMODULES: copying from $sourcefolder/vendormodules to $target_modules_base (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md}]
puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
} else {
puts stderr "VENDORMODULES: No src/vendormodules folder found."
}
}
if {![llength $vendormodulefolders]} {
puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found."
}
########################################################
@ -516,11 +658,22 @@ foreach layoutbase $layout_bases {
}
########################################################
#consolidated /modules /modules_tclX folder used for target where X is tcl major version
#the make process will process for any _tclX not just the major version of the current interpreter
#default source module folder is at projectroot/src/modules
#default source module folders are at projectroot/src/modules and projectroot/src/modules_tclX (where X is tcl major version)
#There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root)
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot]
puts stdout "SOURCEMODULES: scanning [llength $source_module_folderlist] folders"
foreach src_module_dir $source_module_folderlist {
set mtail [file tail $src_module_dir]
if {[string match "modules_tcl*" $mtail]} {
set target_modules_base $projectroot/$mtail
} else {
set target_modules_base $projectroot/modules
}
file mkdir $target_modules_base
puts stderr "Processing source module dir: $src_module_dir"
set dirtail [file tail $src_module_dir]
#modules and associated files belonging to this package/app

53
src/modules/#modpod-modpodtest-999999.0a1.0/#modpod-loadscript.tcl

@ -0,0 +1,53 @@
apply {code {
set scriptpath [file normalize [info script]]
if {[string match "#modpod-loadscript*.tcl" [file tail $scriptpath]]} {
#jump up an extra dir level if we are within a #modpod-loadscript file.
set mypath [file dirname [file dirname $scriptpath]]
#expect to be in folder #modpod-<module>-<ver>
#Now we need to test if we are in a mounted folder vs an extracted folder
set container [file dirname $mypath]
if {[string match "#mounted-modpod-*" $container]} {
set mypath [file dirname $container]
}
set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #modpod-<module>-<ver>
} else {
set mypath [file dirname $scriptpath]
set modver [file root [file tail [info script]]]
}
set mysegs [file split $mypath]
set overhang [list]
foreach libpath [tcl::tm::list] {
set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & /
if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} {
#mypath is below libpath
set overhang [lrange $mysegs [llength $libsegs]+1 end]
break
}
}
lassign [split $modver -] moduletail version
set ns [join [concat $overhang $moduletail] ::]
#if {![catch {package require modpod}]} {
# ::modpod::disconnect [info script]
#}
package provide $ns $version
namespace eval $ns $code
} ::} {
#
# Module procs here, where current namespace is that of the module.
# Package version can, if needed, be accessed as [uplevel 1 {set version}]
# Last element of module name: [uplevel 1 {set moduletail}]
# Full module name: [uplevel 1 {set ns}]
#<modulecode>
#
#</modulecode>
#<sourcefiles>
#
#</sourcefiles>
#<loadfiles>
#
#</loadfiles>
}

2
src/modules/#modpod-modpodtest-999999.0a1.0/#z

@ -0,0 +1,2 @@
#Do not remove the trailing ctrl-z character from this file


181
src/modules/#modpod-modpodtest-999999.0a1.0/modpodtest-999999.0a1.0.tm

@ -0,0 +1,181 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application modpodtest 999999.0a1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_modpodtest 0 999999.0a1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require modpodtest]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of modpodtest
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by modpodtest
#[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 modpodtest::class {
#*** !doctools
#[subsection {Namespace modpodtest::class}]
#[para] class definitions
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval modpodtest {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
#*** !doctools
#[subsection {Namespace modpodtest}]
#[para] Core API functions for modpodtest
#[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"
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace modpodtest ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval modpodtest::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace modpodtest::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 modpodtest::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval modpodtest::system {
#*** !doctools
#[subsection {Namespace modpodtest::system}]
#[para] Internal functions that are not part of the API
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide modpodtest [tcl::namespace::eval modpodtest {
variable pkg modpodtest
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]

120
src/modules/#modpod-zipper-0.11/zipper-0.11.tm

@ -0,0 +1,120 @@
# ZIP file constructor
package provide zipper 0.11
namespace eval zipper {
namespace export initialize addentry finalize
namespace eval v {
variable fd
variable base
variable toc
}
proc initialize {fd} {
set v::fd $fd
set v::base [tell $fd]
set v::toc {}
fconfigure $fd -translation binary -encoding binary
}
proc emit {s} {
puts -nonewline $v::fd $s
}
proc dostime {sec} {
set f [clock format $sec -format {%Y %m %d %H %M %S} -gmt 1]
regsub -all { 0(\d)} $f { \1} f
foreach {Y M D h m s} $f break
set date [expr {(($Y-1980)<<9) | ($M<<5) | $D}]
set time [expr {($h<<11) | ($m<<5) | ($s>>1)}]
return [list $date $time]
}
proc addentry {name contents {date ""} {force 0}} {
if {$date == ""} { set date [clock seconds] }
foreach {date time} [dostime $date] break
set flag 0
set type 0 ;# stored
set fsize [string length $contents]
set csize $fsize
set fnlen [string length $name]
if {$force > 0 && $force != [string length $contents]} {
set csize $fsize
set fsize $force
set type 8 ;# if we're passing in compressed data, it's deflated
}
if {[catch { zlib crc32 $contents } crc]} {
set crc 0
} elseif {$type == 0} {
set cdata [zlib deflate $contents]
if {[string length $cdata] < [string length $contents]} {
set contents $cdata
set csize [string length $cdata]
set type 8 ;# deflate
}
}
lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \
$flag $type $time $date $crc $csize $fsize $fnlen \
{0 0 0 0} 128 [tell $v::fd]]$name"
emit [binary format a2c4ssssiiiss PK {3 4 20 0} \
$flag $type $time $date $crc $csize $fsize $fnlen 0]
emit $name
emit $contents
}
proc finalize {} {
set pos [tell $v::fd]
set ntoc [llength $v::toc]
foreach x $v::toc { emit $x }
set v::toc {}
set len [expr {[tell $v::fd] - $pos}]
incr pos -$v::base
emit [binary format a2c2ssssiis PK {5 6} 0 0 $ntoc $ntoc $len $pos 0]
return $v::fd
}
}
if {[info exists pkgtest] && $pkgtest} {
puts "no test code"
}
# test code below runs when this is launched as the main script
if {[info exists argv0] && [string match zipper-* [file tail $argv0]]} {
catch { package require zlib }
zipper::initialize [open try.zip w]
set dirs [list .]
while {[llength $dirs] > 0} {
set d [lindex $dirs 0]
set dirs [lrange $dirs 1 end]
foreach f [lsort [glob -nocomplain [file join $d *]]] {
if {[file isfile $f]} {
regsub {^\./} $f {} f
set fd [open $f]
fconfigure $fd -translation binary -encoding binary
zipper::addentry $f [read $fd] [file mtime $f]
close $fd
} elseif {[file isdir $f]} {
lappend dirs $f
}
}
}
close [zipper::finalize]
puts "size = [file size try.zip]"
puts [exec unzip -v try.zip]
file delete try.zip
}

28
src/modules/#modpod-zipper-0.11/zipper.README

@ -0,0 +1,28 @@
Creating ZIP archives in Tcl
============================
Rev 0.11: Added ?force? arg to bypass re-compression
Rev 0.10: Initial release
Zipper is a package to create ZIP archives with a few simple commands:
zipper::initialize $fd
initialize things to start writing zip file entries
zipper::addentry name contents ?date? ?force?
add one entry, modification date defaults to [clock seconds]
zipper::finalize
write trailing table of contents, returns file descriptor
Example:
package require zipper
zipper::initialize [open try.zip w]
zipper::addentry dir/file.txt "some data to store"
close [zipper::finalize]
If the "zlib" package is available, it will be used to to compress the
data when possible and to calculate proper CRC-32 checksums. Otherwise,
the output file will contain uncompressed data and zero checksums.

3
src/modules/modpodtest-buildversion.txt

@ -0,0 +1,3 @@
0.1.0
#First line must be a semantic version number
#all other lines are ignored.

273
src/modules/punk-0.1.tm

@ -505,6 +505,8 @@ namespace eval punk {
proc splitstrposn_nonzero {s p} {
scan $s %${p}s%s
}
#split top level of patterns only.
proc _split_patterns {varspecs} {
set name_mapped [pipecmd_namemapping $varspecs]
set cmdname ::punk::pipecmds::split_patterns_$name_mapped
@ -519,11 +521,13 @@ namespace eval punk {
# % string functions
# ! not
set var_terminals [list "@" "/" "#" "%" "!" ">" "<"] ;# (> required for insertionspecs at rhs of = & .= )
#right bracket ) also ends a var - but is different depending on whether var is array or basic. For array - it forms part of the varname
#except when prefixed directly by pin classifier ^
set protect_terminals [list "^"] ;# e.g sequence ^#
#also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string
#ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et'
set in_brackets 0
set in_brackets 0 ;#count depth
set in_atom 0
#set varspecs [string trimleft $varspecs ,]
set token ""
@ -532,22 +536,38 @@ namespace eval punk {
#}
set first_term -1
set token_index 0 ;#index of terminal char within each token
set indq 0
set inesc 0 ;#whether last char was backslash (see also punk::escv)
set prevc ""
set char_index 0
foreach c [split $varspecs ""] {
if {$in_atom} {
if {$indq} {
if {$inesc} {
#puts stderr "inesc adding '$c'"
append token $c
} else {
if {$c eq {"}} {
set indq 0
} else {
append token $c
}
}
} elseif {$in_atom} {
#ignore dquotes/brackets in atoms - pass through
append token $c
#set nextc [lindex $chars $char_index+1]
if {$c eq "'"} {
set in_atom 0
}
} elseif {$in_brackets} {
} elseif {$in_brackets > 0} {
append token $c
if {$c eq ")"} {
set in_brackets 0
incr in_brackets -1
}
} else {
if {$c eq ","} {
if {$c eq {"} && !$inesc} {
set indq 1
} elseif {$c eq ","} {
#lappend varlist [splitstrposn $token $first_term]
set var $token
set spec ""
@ -568,16 +588,33 @@ namespace eval punk {
set first_term -1
} else {
append token $c
switch -exact -- $c {
' {
set in_atom 1
}
( {
incr in_brackets
}
default {
if {$first_term == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} {
set first_term $token_index
} elseif {$c eq "'"} {
set in_atom 1
} elseif {$c eq "("} {
set in_brackets 1
}
}
}
}
}
set prevc $c
if {$c eq "\\"} {
#review
if {$inesc} {
set inesc 0
} else {
set token [string range $token 0 end-1]
set inesc 1
}
} else {
set inesc 0
}
incr token_index
incr char_index
}
@ -1268,8 +1305,10 @@ namespace eval punk {
append script \n "# index_operation listindex-nested" \n
lappend INDEX_OPERATIONS listindex-nested
}
append script \n [string map [list <subindices> $subindices] {
set leveldata [lindex $leveldata <subindices>]
append script \n [tstr -return string -allowcommands {
if {[catch {lindex $leveldata ${$subindices}} leveldata]} {
${[tstr -ret string $tpl_return_mismatch_not_a_list]}
}
}]
# -- --- ---
#append script \n $returnline \n
@ -1283,7 +1322,7 @@ namespace eval punk {
set keypath [string range $selector 2 end]
set keylist [split $keypath /]
lappend INDEX_OPERATIONS dict_path
if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1)} {
if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1) && ([lsearch $keylist %*] == -1)} {
#pure keylist for dict - process in one go
#dict exists will return 0 if not a valid dict.
#<keylist> is equivalent to {*}keylist when substituted
@ -1333,7 +1372,7 @@ namespace eval punk {
#thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values.
#append script \n {set do_boundscheck 0}
switch -exact -- $index {
# {
# - @# {
#list length
set active_key_type "list"
if {$get_not} {
@ -1395,16 +1434,96 @@ namespace eval punk {
append script \n {set assigned [string length $leveldata]}
set level_script_complete 1
}
%%# {
#experimental
set active_key_type "string"
if $get_not {
error "!%%# not string length is not supported"
}
#string length - REVIEW -
lappend INDEX_OPERATIONS ansistring-length
append script \n {# set active_key_type "" index_operation: ansistring-length}
append script \n {set assigned [ansistring length $leveldata]}
set level_script_complete 1
}
%str {
set active_key_type "string"
if $get_not {
error "!%# not string-get is not supported"
error "!%str - not string-get is not supported"
}
lappend INDEX_OPERATIONS string-get
append script \n {# set active_key_type "" index_operation: string-get}
append script \n {set assigned $leveldata}
set level_script_complete 1
}
%sp {
#experimental
set active_key_type "string"
if $get_not {
error "!%sp - not string-space is not supported"
}
lappend INDEX_OPERATIONS string-space
append script \n {# set active_key_type "" index_operation: string-space}
append script \n {set assigned " "}
set level_script_complete 1
}
%empty {
#experimental
set active_key_type "string"
if $get_not {
error "!%empty - not string-empty is not supported"
}
lappend INDEX_OPERATIONS string-empty
append script \n {# set active_key_type "" index_operation: string-empty}
append script \n {set assigned ""}
set level_script_complete 1
}
@words {
set active_key_type "string"
if $get_not {
error "!%words - not list-words-from-string is not supported"
}
lappend INDEX_OPERATIONS list-words-from-string
append script \n {# set active_key_type "" index_operation: list-words-from-string}
append script \n {set assigned [regexp -inline -all {\S+} $leveldata]}
set level_script_complete 1
}
@chars {
#experimental - leading character based on result not input(?)
#input type is string - but output is list
set active_key_type "list"
if $get_not {
error "!%chars - not list-chars-from-string is not supported"
}
lappend INDEX_OPERATIONS list-from_chars
append script \n {# set active_key_type "" index_operation: list-chars-from-string}
append script \n {set assigned [split $leveldata ""]}
set level_script_complete 1
}
@join {
#experimental - flatten one level of list
#join without arg - output is list
set active_key_type "string"
if $get_not {
error "!@join - not list-join-list is not supported"
}
lappend INDEX_OPERATIONS list-join-list
append script \n {# set active_key_type "" index_operation: list-join-list}
append script \n {set assigned [join $leveldata]}
set level_script_complete 1
}
%join {
#experimental
#input type is list - but output is string
set active_key_type "string"
if $get_not {
error "!%join - not string-join-list is not supported"
}
lappend INDEX_OPERATIONS string-join-list
append script \n {# set active_key_type "" index_operation: string-join-list}
append script \n {set assigned [join $leveldata ""]}
set level_script_complete 1
}
%ansiview {
set active_key_type "string"
if $get_not {
@ -1434,7 +1553,7 @@ namespace eval punk {
#v_list_idx in context of _multi_bind_result
append script \n {upvar v_list_idx v_list_idx}
set active_key_type "list"
append script \n {# set active_key_type "list" index_operation: get-next}
append script \n {# set active_key_type "list" index_operation: list-get-next}
#e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey
#no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3
#while x@,y@.= is reasonably handy - especially for args e.g <a@,b@,c@| v1 v2 v3 instead of requiring <a@0,b@1,c@2|
@ -1446,7 +1565,7 @@ namespace eval punk {
#set index [expr {$next_this_level -1}]
if {$get_not} {
lappend INDEX_OPERATIONS has-next
lappend INDEX_OPERATIONS list-has-next
append script \n [tstr -return string -allowcommands {
set index [expr {[set v_list_idx(@)]}] ;#test without moving index - review
if {[catch {llength $leveldata} len]} {
@ -1477,6 +1596,31 @@ namespace eval punk {
}
set level_script_complete 1
}
@* {
set active_key_type "list"
if {$get_not} {
lappend INDEX_OPERATIONS list-is-empty
append script \n [tstr -return string -allowcommands {
if {[catch {llength $leveldata} len]} {
${[tstr -ret string $tpl_return_mismatch_not_a_list]}
} elseif {$len == 0} {
set assigned 1 ;#list is empty
} else {
set assigned 0
}
}]
} else {
lappend INDEX_OPERATIONS list-get-all
append script \n [tstr -return string -allowcommands {
if {[catch {llength $leveldata} len]} {
${[tstr -ret string $tpl_return_mismatch_not_a_list]}
} else {
set assigned [lrange $leveldata 0 end]
}
}]
}
set level_script_complete 1
}
@@ {
#stateful: tracking of index using v_dict_idx
set active_key_type "dict"
@ -1963,7 +2107,7 @@ namespace eval punk {
set level_script_complete 1
}
{@\*\*@} {
{@\*\*@*} {
#dict val/key glob return pairs)
set active_key_type "dict"
set keyvalglob [string range $index 4 end]
@ -2043,10 +2187,21 @@ namespace eval punk {
lappend INDEX_OPERATIONS listindex-zero-not
set assignment_script {set assigned [lrange $leveldata 1 end]}
} else {
append script \n "# index_operation listindex-int" \n
lappend INDEX_OPERATIONS listindex-zero
set assignment_script {set assigned [lindex $leveldata 0]}
if {$do_bounds_check} {
append script \n "# index_operation listindex-int (bounds checked)" \n
append script \n [tstr -return string -allowcommands {
if {[catch {llength $leveldata} len]} {
${[tstr -ret string $tpl_return_mismatch_not_a_list]}
} elseif {[llength $leveldata] == 0} {
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]}
} else {
${$assignment_script}
}
}]
} else {
append script \n "# index_operation listindex-int" \n
append script \n [tstr -return string -allowcommands {
if {[catch {llength $leveldata} len]} {
${[tstr -ret string $tpl_return_mismatch_not_a_list]}
@ -2055,6 +2210,8 @@ namespace eval punk {
}
}]
}
}
}
head {
#NOTE: /@head and /head both do bounds check. This is intentional
if {$get_not} {
@ -2612,7 +2769,9 @@ namespace eval punk {
return $script
}
#todo - recurse into bracketed sub parts
#JMN3
#e.g @*/(x@0,y@2)
proc _var_classify {multivar} {
set cmdname ::punk::pipecmds::var_classify_[pipecmd_namemapping $multivar]
if {$cmdname in [info commands $cmdname]} {
@ -2692,6 +2851,8 @@ namespace eval punk {
}
"#" {
#pinned numeric comparison instead of string comparison
#e.g set x 2
# this should match: ^#x.= list 2.0
lappend classes 8
set vname [string range $vname 1 end]
}
@ -3793,7 +3954,7 @@ namespace eval punk {
} else {
append script [string map [list <scopep> $scopepattern] {
#we still need to bind whether list is empty or not to allow any patternmatch to succeed/fail
set d [punk::_multi_bind_result "<scopep>" $segmenttail]
set d [punk::_multi_bind_result {<scopep>} $segmenttail]
#return [punk::_handle_bind_result $d]
#maintenance: inlined
if {![dict exists $d result]} {
@ -3816,6 +3977,7 @@ namespace eval punk {
}
#return a script for inserting data into listvar
#review - needs updating for list-return semantics of patterns?
proc list_insertion_script {keyspec listvar {data <data>}} {
set positionspec [string trimright $keyspec "*"]
set do_expand [expr {[string index $keyspec end] eq "*"}]
@ -4495,7 +4657,7 @@ namespace eval punk {
}
append insertion_script \n {set insertion_data $v}
} else {
#todo - we should potentially group by the variable name and pass as a single call to _multi_bind_result - because stateful @ and @@ won't work in independent calls
append insertion_script \n [string map [list <cmdname> $cmdname] {
#puts ">>> v: $v dict_tagval:'$dict_tagval'"
if {$v eq ""} {
@ -5068,7 +5230,10 @@ namespace eval punk {
#lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}]
#lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}]
if {![dict get $::punk::config::running exec_unknown]} {
if {[dict get $::punk::config::running auto_exec_mechanism] eq "experimental"} {
#TODO - something cross-platform that allows us to maintain a separate console(s) with an additional set of IO channels to drive it
#not a trivial task
#This runs external executables in a context in which they are not attached to a terminal
#VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output
#ctrl-c propagation also needs to be considered
@ -5374,8 +5539,6 @@ namespace eval punk {
#
#know {[regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args}
#know {[regexp {^{([^\t\r\n=]*)\=([^ \t\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args}
know {[regexp {^([^\t\r\n=]*)\=([^\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args}
know {[regexp {^{([^\t\r\n=]*)\=([^\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args}
@ -5449,9 +5612,43 @@ namespace eval punk {
return [uplevel 1 [list ::punk::pipeline .= $pattern $equalsrhs {*}$argstail]]
}
#
know {[regexp {^([^\t\r\n=]*)\=([^\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args}
know {[regexp {^{([^\t\r\n=]*)\=([^\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args}
#variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)}
#know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args}
know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args}
#know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args}
#know {[regexp {^([^\t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args}
#know {[regexp {^([^\t\r\n=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args}
know {[regexp {^([^=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args}
#add escaping backslashes to a value
#matching odd keys in dicts using pipeline syntax can be tricky - as
#e.g
#set ktest {a"b}
#@@[escv $ktest].= list a"b val
#without escv:
#@@"a\\"b".= list a"b val
#with more backslashes in keys the escv use becomes more apparent:
#set ktest {\\x}
#@@[escv $ktest].= list $ktest val
#without escv we would need:
#@@\\\\\\\\x.= list $ktest val
proc escv {v} {
#https://stackoverflow.com/questions/11135090/is-there-any-tcl-function-to-add-escape-character-automatically
#thanks to DKF
regsub -all {\W} $v {\\&}
}
interp alias {} escv {} punk::escv
#review
#set v "\u2767"
#<char>
#escv $v
#\<char>
#the
#know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} {
# set argstail [lassign $args hd]
@ -7859,7 +8056,7 @@ namespace eval punk {
set displaycount ""
}
if {$opt_ansi == 0} {
set displayval [punk::ansi::stripansi $displayval]
set displayval [punk::ansi::ansistrip $displayval]
} elseif {$opt_ansi == 2} {
set displayval [ansistring VIEW $displayval]
}
@ -7951,20 +8148,26 @@ namespace eval punk {
set text ""
if {$topic in [list env environment]} {
#todo - move to punk::config?
upvar ::punk::config::punk_env_vars_config punkenv_config
upvar ::punk::config::other_env_vars_config otherenv_config
set known_punk $::punk::config::known_punk_env_vars
set known_other $::punk::config::known_other_env_vars
set known_punk [dict keys $punkenv_config]
set known_other [dict keys $otherenv_config]
append text \n
set usetable 1
if {$usetable} {
set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]]
foreach v $known_punk {
foreach {v vinfo} $punkenv_config {
if {[info exists ::env($v)]} {
set c2 [set ::env($v)]
} else {
set c2 "(NOT SET)"
}
$t add_row [list $v $c2]
set help ""
if {[dict exists $vinfo help]} {
set help [dict get $vinfo help]
}
$t add_row [list $v $c2 $help]
}
$t configure_column 0 -headers [list "Punk environment vars"]
$t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any}
@ -7973,7 +8176,7 @@ namespace eval punk {
$t destroy
set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]]
foreach v $known_other {
foreach {v vinfo} $otherenv_config {
if {[info exists ::env($v)]} {
set c2 [set ::env($v)]
} else {
@ -8318,13 +8521,15 @@ namespace eval punk {
# ls aliases - note that tcl doesn't exand * but sh_xxx functions pass to sh -c allowing shell expansion
interp alias {} l {} sh_runout -n ls -A ;#plain text listing
#interp alias {} ls {} sh_runout -n ls -AF --color=always
interp alias {} ls {} unknown ls -AF --color=always ;#use unknown to use terminal and allow | more | less
interp alias {} ls {} shellrun::runconsole ls -AF --color=always ;#use unknown to use terminal and allow | more | less
#note that shell globbing with * won't work on unix systems when using unknown/exec
interp alias {} lw {} sh_runout -n ls -AFC --color=always ;#wide listing (use A becaus no extra info on . & ..)
interp alias {} ll {} sh_runout -n ls -laFo --color=always ;#use a instead of A to see perms/owner of . & ..
# -v for natural number sorting not supported on freeBSD. Todo - test at startup and modify aliases?
#interp alias {} lw {} ls -aFv --color=always
interp alias {} dir {} shellrun::console dir
interp alias {} ./ {} punk::d/
interp alias {} ../ {} punk::dd/
@ -8358,8 +8563,8 @@ namespace eval punk {
interp alias {} psr {} run -n pwsh -nop -nolo -c
interp alias {} psout {} runout -n pwsh -nop -nolo -c
interp alias {} pserr {} runerr -n pwsh -nop -nolo -c
interp alias {} psls {} pwsh -nop -nolo -c ls
interp alias {} psps {} pwsh -nop -nolo -c ps
interp alias {} psls {} shellrun::runconsole pwsh -nop -nolo -c ls
interp alias {} psps {} shellrun::runconsole pwsh -nop -nolo -c ps
} else {
set ps_missing "powershell missing (powershell is open source and can be installed on windows and most unix-like platforms)"
interp alias {} ps {} puts stderr $ps_missing

18
src/modules/punk/aliascore-999999.0a1.0.tm

@ -112,7 +112,8 @@ tcl::namespace::eval punk::aliascore {
plist [list ::punk::lib::pdict -roottype list]\
showlist [list ::punk::lib::showdict -roottype list]\
showdict ::punk::lib::showdict\
ansistrip ::punk::ansi::stripansi\
ansistrip ::punk::ansi::ansistrip\
stripansi ::punk::ansi::ansistrip\
]
#*** !doctools
@ -165,18 +166,31 @@ tcl::namespace::eval punk::aliascore {
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]
}
@ -188,7 +202,7 @@ tcl::namespace::eval 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::stripansi ;#review
#interp alias {} ansistrip {} punk::ansi::ansistrip ;#review
#interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features
#interp alias {} linesort {} punk::lib::linesort

128
src/modules/punk/ansi-999999.0a1.0.tm

@ -265,13 +265,13 @@ tcl::namespace::eval punk::ansi::class {
}
set opts_width [tcl::dict::get $opts -width]
if {$opts_width eq ""} {
return [punk::ansi::stripansiraw [$o_ansistringobj get]]
return [punk::ansi::ansistripraw [$o_ansistringobj get]]
} elseif {$opts_width eq "auto"} {
lassign [punk::console::get_size] _cols columns _rows rows
set displaycols [expr {$columns -4}] ;#review
return [overtype::renderspace -width $displaycols -wrap 1 "" [punk::ansi::stripansiraw [$o_ansistringobj get]]]
return [overtype::renderspace -width $displaycols -wrap 1 "" [punk::ansi::ansistripraw [$o_ansistringobj get]]]
} elseif {[tcl::string::is integer -strict $opts_width] && $opts_width > 0} {
return [overtype::renderspace -width $opts_width -wrap 1 "" [punk::ansi::stripansiraw [$o_ansistringobj get]]]
return [overtype::renderspace -width $opts_width -wrap 1 "" [punk::ansi::ansistripraw [$o_ansistringobj get]]]
} else {
error "viewchars unrecognised value for -width. Try auto or a positive integer"
}
@ -420,7 +420,7 @@ tcl::namespace::eval punk::ansi {
get_*\
move*\
reset*\
strip*\
ansistrip*\
test_decaln\
titleset\
@ -750,7 +750,7 @@ tcl::namespace::eval punk::ansi {
#mqj
#m = boxd_lur
#don't call detect_g0 in here. Leave for caller. e.g stripansi uses detect_g0 to decide whether to call this.
#don't call detect_g0 in here. Leave for caller. e.g ansistrip uses detect_g0 to decide whether to call this.
set re_g0_open_or_close {\x1b\(0|\x1b\(B}
set parts [::punk::ansi::ta::_perlish_split $re_g0_open_or_close $text]
@ -813,7 +813,7 @@ tcl::namespace::eval punk::ansi {
proc g0 {text} {
return \x1b(0$text\x1b(B
}
proc stripansi_gx {text} {
proc ansistrip_gx {text} {
#e.g "\033(0" - select VT100 graphics for character set G0
#e.g "\033(B" - reset
#e.g "\033)0" - select VT100 graphics for character set G1
@ -822,6 +822,9 @@ tcl::namespace::eval punk::ansi {
#return [convert_g0 $text]
return [tcl::string::map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text]
}
proc stripansi_gx {text} {
return [tcl::string::map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text]
}
#CSI <n> m = SGR (Select Graphic Rendition)
@ -1085,7 +1088,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#This is an in depth analysis of the xterm colour set which gives names(*) to all of the 256 colours and describes possible indexing by Hue,Luminance,Saturation
#https://www.wowsignal.io/articles/xterm256
#*The names are wildly-imaginative, often unintuitively so, and multiple (5?) given for each colour - so they are unlikely to be of practical use or any sort of standard.
# *The names are wildly-imaginative, often unintuitively so, and multiple (5?) given for each colour - so they are unlikely to be of practical use or any sort of standard.
#e.g who is to know that 'Rabbit Paws', 'Forbidden Thrill' and 'Tarsier' refer to a particular shade of pinky-red? (code 95)
#Perhaps it's an indication that colour naming once we get to 256 colours or more is a fool's errand anyway.
#The xterm names are boringly unimaginative - and also have some oddities such as:
@ -2263,23 +2266,25 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#sgr_cache clear called by punk::console::ansi when set to off
proc sgr_cache {args} {
set argd [punk::args::get_dict {
-action -default "" -choices "clear"
-pretty -default 1 -help "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output"
*proc -name punk::ansi::sgr_cache -help "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes)
"
-action -default "" -choices "clear" -help "-action clear will unset the keys in the punk::ansi::sgr_cache dict
This is called automatically when setting 'colour false' in the console"
-pretty -default 1 -type boolean -help "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output"
*values -min 0 -max 0
} $args]
set action [dict get $argd opts -action]
set pretty [dict get $argd opts -pretty]
variable sgr_cache
if {$action ni {"" clear}} {
error "sgr_cache action '$action' not understood. Valid actions: clear"
}
if {$action eq "clear"} {
set sgr_cache [tcl::dict::create]
return "sgr_cache cleared"
}
if {$pretty} {
return [pdict -channel none sgr_cache */%str,%ansiview]
#return [pdict -channel none sgr_cache */%str,%ansiview]
return [pdict -channel none sgr_cache */%rpadstr-"sample",%ansiviewstyle]
}
if {[catch {
@ -2323,7 +2328,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#function name part of cache-key because a and a+ return slightly different results (a has leading reset)
variable sgr_cache
set cache_key a+$args ;#ensure cache_key static - we may remove for example 'forcecolour' from args - but it needs to remain part of cache_key
set cache_key "a+ $args" ;#ensure cache_key static - we may remove for example 'forcecolour' from args - but it needs to remain part of cache_key
if {[tcl::dict::exists $sgr_cache $cache_key]} {
return [tcl::dict::get $sgr_cache $cache_key]
}
@ -2682,7 +2687,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#It's important to put the functionname in the cache-key because a and a+ return slightly different results
variable sgr_cache
set cache_key a_$args
set cache_key "a $args"
if {[tcl::dict::exists $sgr_cache $cache_key]} {
return [tcl::dict::get $sgr_cache $cache_key]
}
@ -2693,7 +2698,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
variable TERM_colour_map
set colour_disabled 0
#whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache clear
#whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache -action clear
if {[tcl::info::exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} {
set colour_disabled 1
}
@ -3393,10 +3398,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#arguably - \b and \r are cursor move operations too - so processing them here is not very symmetrical - review
#the purpose of backspace (or line cr) in embedded text is unclear. Should it allow some sort of character combining/overstrike as it has sometimes done historically (nroff/less)? e.g a\b` as an alternative combiner or bolding if same char
#This should presumably only be done if the over_strike (os) capability is enabled in the terminal. Either way - it presumably won't affect printing width?
set line [punk::ansi::stripansi $line]
set line [punk::ansi::ansistrip $line]
#we can't use simple \b processing if we get ansi codes and aren't actually processing them (e.g moves)
set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after stripansi - some like BEL are part of ansi
set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after ansistrip - some like BEL are part of ansi
#backspace 0x08 only erases* printing characters anyway - so presumably order of processing doesn't matter
#(* more correctly - moves cursor back)
#Note some terminals process backspace before \v - which seems quite wrong
@ -3512,6 +3517,40 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#ever so slightly slower on short strings - much faster than split_at_codes version for large/complex ansi blocks
proc ansistrip {text} {
#*** !doctools
#[call [fun ansistrip] [arg text] ]
#[para]Return a string with ansi codes stripped out
#[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs)
if {[punk::ansi::ta::detect_g0 $text]} {
set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters
}
set parts [punk::ansi::ta::split_codes $text]
set out ""
foreach {pt code} $parts {
append out $pt
}
return $out
}
#interp alias {} stripansi {} ::punk::ansi::ansistrip
proc ansistripraw {text} {
#*** !doctools
#[call [fun ansistripraw] [arg text] ]
#[para]Return a string with ansi codes stripped out
#[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode.
#[para]ie instead of a horizontal line you may see: qqqqqq
set parts [punk::ansi::ta::split_codes $text]
set out ""
foreach {pt code} $parts {
append out $pt
}
return $out
}
#interp alias {} stripansiraw {} ::punk::ansi::ansistripraw
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::ansi ---}]
}
@ -4293,16 +4332,16 @@ tcl::namespace::eval punk::ansi::ta {
#*** !doctools
#[call [fun strip] [arg text]]
#[para]Return text stripped of Ansi codes
#[para]This is a tailcall to punk::ansi::stripansi
tailcall stripansi $text
#[para]This is a tailcall to punk::ansi::ansistrip
tailcall ansistrip $text
}
proc length {text} {
#*** !doctools
#[call [fun length] [arg text]]
#[para]Return the character length after stripping ansi codes - not the printing length
#we can use stripansiraw to avoid g0 conversion - as the length should remain the same
tcl::string::length [stripansiraw $text]
#we can use ansistripraw to avoid g0 conversion - as the length should remain the same
tcl::string::length [ansistripraw $text]
}
#todo - handle newlines
#not in perl ta
@ -5451,32 +5490,8 @@ tcl::namespace::eval punk::ansi::class {
}
}
tcl::namespace::eval punk::ansi {
proc stripansi {text} {
#ever so slightly slower on short strings - much faster than split_at_codes version for large/complex ansi blocks
if {[punk::ansi::ta::detect_g0 $text]} {
set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters
}
set parts [punk::ansi::ta::split_codes $text]
set out ""
foreach {pt code} $parts {
append out $pt
}
return $out
}
proc stripansiraw {text} {
#slightly slower on short strings - much faster than split_at_codes version for large/complex ansi blocks
set parts [punk::ansi::ta::split_codes $text]
set out ""
foreach {pt code} $parts {
append out $pt
}
return $out
}
proc stripansi3 {text} [string map [list <re> $::punk::ansi::ta::re_ansi_split] {
#*** !doctools
#[call [fun stripansi] [arg text] ]
#[para]Return a string with ansi codes stripped out
#[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs)
#using detect costs us a couple of uS - but saves time on plain text
#we should probably leave this for caller - otherwise it ends up being called more than necessary
@ -5493,11 +5508,6 @@ tcl::namespace::eval punk::ansi {
}]
proc stripansiraw3 {text} [string map [list <re> $::punk::ansi::ta::re_ansi_split] {
#*** !doctools
#[call [fun stripansi] [arg text] ]
#[para]Return a string with ansi codes stripped out
#[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode.
#[para]ie instead of a horizontal line you may see: qqqqqq
#join [::punk::ansi::ta::split_at_codes $text] ""
punk::ansi::ta::Do_split_at_codes_join $text {<re>}
@ -5923,7 +5933,7 @@ tcl::namespace::eval punk::ansi::ansistring {
#[para]Returns the count of visible graphemes and non-ansi control characters
#[para]Incomplete! grapheme clustering support not yet implemented - only diacritics are currently clustered to count as one grapheme.
#[para]This will not count strings hidden inside a 'privacy message' or other ansi codes which may have content between their opening escape and their termination sequence.
#[para]This is not quite equivalent to calling string length on the result of stripansi $string due to diacritics and/or grapheme combinations
#[para]This is not quite equivalent to calling string length on the result of ansistrip $string due to diacritics and/or grapheme combinations
#[para]Note that this returns the number of characters in the payload (after applying combiners)
#It is not always the same as the width of the string as rendered on a terminal due to 2wide Unicode characters and the usual invisible control characters such as \r and \n
#[para]To get the width, use punk::ansi::printing_length instead, which is also ansi aware.
@ -5935,17 +5945,17 @@ tcl::namespace::eval punk::ansi::ansistring {
set string [regsub -all $re_diacritics $string ""]
#we want length to return number of glyphs.. not screen width. Has to be consistent with index function
tcl::string::length [stripansi $string]
tcl::string::length [ansistrip $string]
}
#included as a test/verification - slightly slower.
#grapheme split version may end up being used once it supports unicode grapheme clusters
proc count2 {string} {
#we want count to return number of glyphs.. not screen width. Has to be consistent with index function
return [llength [punk::char::grapheme_split [stripansi $string]]]
return [llength [punk::char::grapheme_split [ansistrip $string]]]
}
proc length {string} {
tcl::string::length [stripansi $string]
tcl::string::length [ansistrip $string]
}
proc _splits_trimleft {sclist} {
@ -6055,9 +6065,9 @@ tcl::namespace::eval punk::ansi::ansistring {
#[para]The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output.
#[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST)
#[para]It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them.
#[para]If the caller wants just the character - they should use a normal string index after calling stripansi, or call stripansi afterwards.
#[para]As any operation using end-+<int> will need to strip ansi to precalculate the length anyway; the caller should probably just use stripansi and standard string index if the ansi coded output isn't required and they are using and end-based index.
#[para]In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using stripansi and normal string operations on that.
#[para]If the caller wants just the character - they should use a normal string index after calling ansistrap, or call ansistrip afterwards.
#[para]As any operation using end-+<int> will need to strip ansi to precalculate the length anyway; the caller should probably just use ansistrip and standard string index if the ansi coded output isn't required and they are using and end-based index.
#[para]In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using ansistrip and normal string operations on that.
#[para]The returned character will (possibly) have a leading ansi escape sequence but no trailing escape sequence - even if the string was taken from a position immediately before a reset or other SGR ansi code
#[para]The ansi-code prefix in the returned string is built up by concatenating previous SGR ansi codes seen - but it is optimised to re-start the process if any full SGR reset is encountered.
#[para]The code sequence doesn't detect individual properties being turned on and then off again, only full resets; so in some cases the ansi-prefix may not be as short as it could be.

31
src/modules/punk/args-999999.0a1.0.tm

@ -267,6 +267,9 @@ tcl::namespace::eval punk::args {
#[list_begin definitions]
#todo? -synonym ? (applies to opts only not values)
#e.g -background -synonym -bg -default White
proc Get_argspecs {optionspecs args} {
variable argspec_cache
variable argspecs
@ -333,7 +336,7 @@ tcl::namespace::eval punk::args {
foreach rawline $linelist {
set recordsofar [tcl::string::cat $linebuild $rawline]
#ansi colours can stop info complete from working (contain square brackets)
if {![tcl::info::complete [punk::ansi::stripansi $recordsofar]]} {
if {![tcl::info::complete [punk::ansi::ansistrip $recordsofar]]} {
#append linebuild [string trimleft $rawline] \n
if {$in_record} {
if {[tcl::string::length $lastindent]} {
@ -696,6 +699,7 @@ tcl::namespace::eval punk::args {
}
proc arg_error {msg spec_dict {badarg ""}} {
# use basic colours here to support terminals without extended colours
#todo - add checks column (e.g -minlen -maxlen)
set errmsg $msg
if {![catch {package require textblock}]} {
@ -704,18 +708,21 @@ tcl::namespace::eval punk::args {
set procname [punk::lib::dict_getdef $spec_dict proc_info -name ""]
set prochelp [punk::lib::dict_getdef $spec_dict proc_info -help ""]
set t [textblock::class::table new [a+ web-yellow]Usage[a]]
#set t [textblock::class::table new [a+ web-yellow]Usage[a]]
set t [textblock::class::table new [a+ brightyellow]Usage[a]]
set blank_header_col [list ""]
if {$procname ne ""} {
lappend blank_header_col ""
set procname_display [a+ web-white]$procname[a]
#set procname_display [a+ web-white]$procname[a]
set procname_display [a+ brightwhite]$procname[a]
} else {
set procname_display ""
}
if {$prochelp ne ""} {
lappend blank_header_col ""
set prochelp_display [a+ web-white]$prochelp[a]
#set prochelp_display [a+ web-white]$prochelp[a]
set prochelp_display [a+ brightwhite]$prochelp[a]
} else {
set prochelp_display ""
}
@ -738,9 +745,12 @@ tcl::namespace::eval punk::args {
$t configure_header 2 -values {Arg Type Default Multiple Help}
}
set c_default [a+ web-white Web-limegreen]
set c_badarg [a+ web-crimson]
set greencheck [a+ web-limegreen]\u2713[a]
#set c_default [a+ web-white Web-limegreen]
set c_default [a+ brightwhite Brightgreen]
#set c_badarg [a+ web-crimson]
set c_badarg [a+ brightred]
#set greencheck [a+ web-limegreen]\u2713[a]
set greencheck [a+ brightgreen]\u2713[a]
foreach arg [dict get $spec_dict opt_names] {
set arginfo [dict get $spec_dict arg_info $arg]
@ -789,7 +799,8 @@ tcl::namespace::eval punk::args {
}
$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ web-white] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow]
#$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ web-white] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow]
$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow]
$t configure -maxwidth 80
append errmsg [$t print]
$t destroy
@ -1209,7 +1220,7 @@ tcl::namespace::eval punk::args {
package require punk::ansi
set vlist_check [list]
foreach e $vlist {
lappend vlist_check [punk::ansi::stripansi $e]
lappend vlist_check [punk::ansi::ansistrip $e]
}
} else {
#validate_without_ansi 0
@ -1437,7 +1448,7 @@ tcl::namespace::eval punk::args {
}
}
if {$is_strip_ansi} {
set stripped_list [lmap e $vlist {punk::ansi::stripansi $e}] ;#no faster or slower, but more concise than foreach
set stripped_list [lmap e $vlist {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach
if {[tcl::dict::get $thisarg -multiple]} {
if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} {
tcl::dict::set opts $argname $stripped_list

6
src/modules/punk/char-999999.0a1.0.tm

@ -1950,7 +1950,7 @@ tcl::namespace::eval punk::char {
#we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!)
#anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error
#if {[tcl::string::first \033 $text] >= 0} {
# error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first"
# error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first"
#}
@ -2057,7 +2057,7 @@ tcl::namespace::eval punk::char {
#we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!)
#anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error
#if {[tcl::string::first \033 $text] >= 0} {
# error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first"
# error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first"
#}
@ -2161,7 +2161,7 @@ tcl::namespace::eval punk::char {
#we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!)
#anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error
#if {[tcl::string::first \033 $text] >= 0} {
# error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first"
# error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first"
#}

195
src/modules/punk/config-0.1.tm

@ -3,11 +3,13 @@ tcl::namespace::eval punk::config {
variable loaded
variable startup ;#include env overrides
variable running
variable known_punk_env_vars
variable known_other_env_vars
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/
@ -16,8 +18,10 @@ tcl::namespace::eval punk::config {
variable defaults
variable startup
variable running
variable known_punk_env_vars
variable known_other_env_vars
variable punk_env_vars
variable punk_env_vars_config
variable other_env_vars
variable other_env_vars_config
set exename ""
catch {
@ -55,12 +59,13 @@ tcl::namespace::eval punk::config {
set default_logfile_stderr ""
}
# exec_unknown ;#whether to use exec instead of experimental shellfilter::run
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run
#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 ""
#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 "web-lightsalmon"
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive
set homedir ""
if {[catch {
@ -134,7 +139,8 @@ tcl::namespace::eval punk::config {
syslog_stdout "127.0.0.1:514"\
syslog_stderr "127.0.0.1:514"\
syslog_active 0\
exec_unknown true\
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\
@ -159,34 +165,56 @@ tcl::namespace::eval punk::config {
#todo - load/save config file
#todo - define which configvars are settable in env
set known_punk_env_vars [list \
PUNK_APPS\
PUNK_CONFIG\
PUNK_CONFIGSET\
PUNK_SCRIPTLIB\
PUNK_EXECUNKNOWN\
PUNK_COLOR_STDERR\
PUNK_COLOR_STDOUT\
PUNK_LOGFILE_STDOUT\
PUNK_LOGFILE_STDERR\
PUNK_LOGFILE_ACTIVE\
PUNK_SYSLOG_STDOUT\
PUNK_SYSLOG_STDERR\
PUNK_SYSLOG_ACTIVE\
PUNK_THEME_POSH_OVERRIDE\
#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}\
PUNK_COLOR_STDOUT {type string}\
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 $known_punk_env_vars {
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)]} {
@ -194,34 +222,77 @@ tcl::namespace::eval punk::config {
# set colour_disabled 1
# }
#}
set known_other_env_vars [list\
NO_COLOR\
XDG_CONFIG_HOME\
XDG_DATA_HOME\
XDG_CACHE_HOME\
XDG_STATE_HOME\
XDG_DATA_DIRS\
POSH_THEME\
POSH_THEMES_PATH\
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}\
]
foreach evar $known_other_env_vars {
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
@ -256,7 +327,8 @@ tcl::namespace::eval punk::config {
set argd [punk::args::get_dict {
whichconfig -type string -choices {startup running}
}]
} $args]
}
proc show {whichconfig} {
@ -279,11 +351,58 @@ tcl::namespace::eval punk::config {
# 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 ?
proc copy {fromconfig toconfig} {
error "sorry - unimplemented"
switch -- $toconfig {
#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"
}
}
}

12
src/modules/punk/console-999999.0a1.0.tm

@ -51,7 +51,7 @@ namespace eval punk::console {
variable ansi_available -1 ;#default -1 for unknown. Leave it this way so test for ansi support is run.
#-1 still evaluates to true - as the modern assumption for ansi availability is true
#only false if ansi_available has been set 0 by test_can_ansi
#support stripansi for legacy windows terminals
#support ansistrip for legacy windows terminals
# --
variable ansi_wanted 2 ;#2 for default assumed yes, will be set to -1 for automatically unwanted when ansi unavailable values of 0 or 1 won't be autoset
@ -780,7 +780,7 @@ namespace eval punk::console {
#stdout
variable ansi_wanted
if {$ansi_wanted <= 0} {
puts -nonewline [punk::ansi::stripansiraw [::punk::ansi::a?]]
puts -nonewline [punk::ansi::ansistripraw [::punk::ansi::a?]]
} else {
tailcall ansi::a? {*}$args
}
@ -806,7 +806,7 @@ namespace eval punk::console {
proc code_a? {args} {
variable ansi_wanted
if {$ansi_wanted <= 0} {
return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]]
return [punk::ansi::ansistripraw [::punk::ansi::a? {*}$args]]
} else {
tailcall ::punk::ansi::a? {*}$args
}
@ -833,7 +833,7 @@ namespace eval punk::console {
false -
no {
set ansi_wanted 0
punk::ansi::sgr_cache clear
punk::ansi::sgr_cache -action clear
}
default {
set ansi_wanted 2
@ -859,7 +859,7 @@ namespace eval punk::console {
if {$on} {
if {$colour_disabled} {
#change of state
punk::ansi::sgr_cache clear
punk::ansi::sgr_cache -action clear
catch {punk::repl::reset_prompt}
set colour_disabled 0
}
@ -867,7 +867,7 @@ namespace eval punk::console {
#we don't disable a/a+ entirely - they must still emit underlines/bold/reverse
if {!$colour_disabled} {
#change of state
punk::ansi::sgr_cache clear
punk::ansi::sgr_cache -action clear
catch {punk::repl::reset_prompt}
set colour_disabled 1
}

12
src/modules/punk/fileline-999999.0a1.0.tm

@ -318,7 +318,7 @@ namespace eval punk::fileline::class {
package require overtype
# will require punk::char and punk::ansi
if {"::punk::fileline::ansi::stripansi" ne [info commands ::punk::fileline::ansi::stripansi]} {
if {"::punk::fileline::ansi::ansistrip" ne [info commands ::punk::fileline::ansi::ansistrip]} {
namespace eval ::punk::fileline::ansi {
namespace import ::punk::ansi::*
}
@ -334,7 +334,7 @@ namespace eval punk::fileline::class {
} else {
set ::punk::fileline::ansi::enabled 0
}
if {"::punk::fileline::stripansi" ne [info commands ::punk::fileline::stripansi]} {
if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} {
proc ::punk::fileline::a {args} {
if {$::punk::fileline::ansi::enabled} {
tailcall ::punk::fileline::ansi::a {*}$args
@ -349,9 +349,9 @@ namespace eval punk::fileline::class {
return ""
}
}
proc ::punk::fileline::stripansi {str} {
proc ::punk::fileline::ansistrip {str} {
if {$::punk::fileline::ansi::enabled} {
tailcall ::punk::fileline::ansi::stripansi $str
tailcall ::punk::fileline::ansi::ansistrip $str
} else {
return $str
}
@ -560,7 +560,7 @@ namespace eval punk::fileline::class {
set title_line "Line"
#todo - use punk::char for unicode support of wide chars etc?
set widest_linenum [tcl::mathfunc::max {*}[lmap v [concat [list $title_linenum] $linenums] {string length $v}]]
set widest_marker [tcl::mathfunc::max {*}[lmap v [concat [list $title_marker] $markers] {string length [stripansi $v]}]]
set widest_marker [tcl::mathfunc::max {*}[lmap v [concat [list $title_marker] $markers] {string length [ansistrip $v]}]]
set widest_status [expr {max([string length $opt_cmark], [string length $opt_tmark])}]
set widest_line [tcl::mathfunc::max {*}[lmap v [concat [list $title_line] $lines] {string length $v}]]
foreach row $result_list {
@ -1711,7 +1711,7 @@ namespace eval punk::fileline::ansi {
#*** !doctools
#[call [fun ansi::a]]
#[call [fun ansi::a+]]
#[call [fun ansi::stripansi]]
#[call [fun ansi::ansistrip]]
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::fileline::ansi ---}]

324
src/modules/punk/lib-999999.0a1.0.tm

@ -66,34 +66,34 @@ package require Tcl 8.6-
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::lib::class {
#*** !doctools
#[subsection {Namespace punk::lib::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 ---}]
}
}
#tcl::namespace::eval punk::lib::class {
# #*** !doctools
# #[subsection {Namespace punk::lib::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 ---}]
# }
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::lib::ensemble {
@ -579,19 +579,53 @@ namespace eval punk::lib {
proc pdict {args} {
set sep " [a+ Web-seagreen]=[a] "
if {[catch {package require punk::ansi} errM]} {
set sep " = "
} else {
#set sep " [a+ Web-seagreen]=[a] "
set sep " [punk::ansi::a+ Green]=[punk::ansi::a] "
}
set argspec [string map [list %sep% $sep] {
*proc -name pdict -help {Print dict keys,values to channel
(see also showdict)}
*opts -any 1
#default separator to provide similarity to tcl's parray function
-separator -default "%sep%"
-roottype -default "dict"
-substructure -default {}
-channel -default stdout -help "existing channel - or 'none' to return as string"
*values -min 1 -max -1
dictvar -type string -help "name of dict variable"
patterns -type string -default "*" -multiple 1
dictvar -type string -help "name of variable. Can be a dict, list or array"
patterns -type string -default "*" -multiple 1 -help {Multiple patterns can be specified as separate arguments.
Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash)
The system uses similar patterns to the punk pipeline pattern-matching system.
The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work.
Segments are classified into list,dict and string operations.
Leading % indicates a string operation - e.g %# gives string length
A segment with a single @ is a list operation e.g @0 gives first list element, @1-3 gives the lrange from 1 to 3
A segment containing 2 @ symbols is a dict operation. e.g @@k1 retrieves the value for dict key 'k1'
The operation type indicator is not always necessary if lower segments in the hierarchy are of the same type as the previous one.
e.g1 pdict env */%#
the pattern starts with default type dict, so * retrieves all keys & values,
the next hierarchy switches to a string operation to get the length of each value.
e.g2 pdict env W* S*
Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns
e.g3 pdict punk_testd */*
This displays 2 levels of the dict hierarchy.
Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all)
- then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator.
e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1
Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent
The second level segement in each pattern switches to a dict operation to retrieve the value by key.
When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level.
The pdict function operates on variable names - passing the value to the showdict function which operates on values
}
}]
#puts stderr "$argspec"
set argd [punk::args::get_dict $argspec $args]
@ -621,20 +655,33 @@ namespace eval punk::lib {
# - The current version is incomplete but passably usable.
# - Copy proc and attempt rework so we can get back to this as a baseline for functionality
proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value)
set sep " [a+ Web-seagreen]=[a] "
set argd [punk::args::get_dict [string map [list %sep% $sep] {
*id punk::lib::pdict
*proc -name punk::lib::pdict -help "display dictionary keys and values"
#set sep " [a+ Web-seagreen]=[a] "
if {[catch {package require punk::ansi} errM]} {
set sep " = "
set RST ""
set sep_mismatch " mismatch "
} else {
set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " ;#stick to basic default colours for wider terminal support
set RST [punk::ansi::a]
set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch[punk::ansi::a] "
}
package require punk ;#we need pipeline pattern matching features
package require textblock
set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] {
*id punk::lib::showdict
*proc -name punk::lib::showdict -help "display dictionary keys and values"
#todo - table tableobject
-return -default "tailtohead" -choices {tailtohead sidebyside}
-channel -default none
-trimright -default 1 -type boolean -help "Trim whitespace off rhs of each line.
This can help prevent a single long line that wraps in terminal from making every line wrap due to long rhs padding
"
-separator -default "%sep%" -help "Separator column between keys and values"
-separator -default {%sep%} -help "Separator column between keys and values"
-separator_mismatch -default {%sep_mismatch%} -help "Separator to use when patterns mismatch"
-roottype -default "dict" -help "list,dict,string"
-substructure -default {}
-ansibase_keys -default "" -help "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]"
-substructure -default {}
-ansibase_values -default ""
-keytemplates -default {${$key}} -type list -help "list of templates for keys at each level"
-keysorttype -default "none" -choices {none dictionary ascii integer real}
@ -644,6 +691,7 @@ namespace eval punk::lib {
patterns -default "*" -type string -multiple 1 -help "key or key glob pattern"
}] $args]
set opt_sep [dict get $argd opts -separator]
set opt_mismatch_sep [dict get $argd opts -separator_mismatch]
set opt_keysorttype [dict get $argd opts -keysorttype]
set opt_keysortdirection [dict get $argd opts -keysortdirection]
set opt_trimright [dict get $argd opts -trimright]
@ -659,10 +707,40 @@ namespace eval punk::lib {
set result ""
#pattern hierarchy
# */@1/@0,%#,%str @0/@1 - patterns each one is a pattern or pattern_nest
# * @1 @0,%#,%str - segments
# a b 1 0 %# %str - keys
set pattern_key_index [list] ;#list of pattern_nests, same length as number of keys generated
set pattern_next_substructure [dict create]
set pattern_this_structure [dict create]
# -- --- --- ---
#REVIEW
#as much as possible we should pass the indices along as a query to the pipeline pattern matching system so we're not duplicating the work and introducing inconsistencies.
#The main difference here is that sometimes we are treating the result as key-val pairs with the key being the query, other times the key is part of the query, or from the result itself (list/dict indices/keys).
#todo - determine if there is a more consistent rule-based way to do this rather than adhoc
#e.g pdict something *
#we want the keys from the result as individual lines on lhs
#e.g pdict something @@<key>
#we want <key> on lhs result on rhs
#<key> = v0
#e.g pdict something @0-2,@4
#we currently return:
#0 = v0
#1 = v1
#2 = v2
#4 = v4
#This means we've effectively auto-expanded the first list - elements 0-2. (or equivalently stated: we've flattened the 3 element and 1 element lists into one list of 4 elements)
#ie pdict is doing 'magic' compared to the normal pattern matching syntax, to make useage more convenient.
#this is a tradeoff that could create surprises and make things messy and/or inconsistent.
#todo - see if we can find a balance that gives consistency and logicality to the results whilst allowing still simplified matching syntax that is somewhat intuitive.
#It may be a matter of documenting what type of indexes are used directly as keys, and which return sets of further keys
#The solution for more consistency/predictability may involve being able to bracket some parts of the segment so for example we can apply an @join or %join within a segment
#that involves more complex pattern syntax & parsing (to be added to the main pipeline pattern syntax)
# -- --- --- ---
set filtered_keys [list]
if {$opt_roottype in {dict list string}} {
#puts "getting keys for roottype:$opt_roottype"
@ -671,53 +749,80 @@ namespace eval punk::lib {
set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$}
foreach pattern_nest $patterns {
set keyset [list]
set pattern_nest_list [split $pattern_nest /]
set p [lindex $pattern_nest_list 0]
set keyset_structure [list]
set segments [split $pattern_nest /]
set levelpatterns [lindex $segments 0] ;#possibly comma separated patterns
#we need to use _split_patterns to separate (e.g to protext commas that appear within quotes)
set patterninfo [punk::_split_patterns $levelpatterns]
#puts stderr "showdict-->_split_patterns: $patterninfo"
foreach v_idx $patterninfo {
lassign $v_idx v idx
#we don't support vars on lhs of index in this context - (because we support simplified glob patterns such as x* and literal dict keys such as kv which would otherwise be interpreted as vars with no index)
set p $v$idx ;#_split_patterns has split too far in this context - the entire pattern is the index pattern
switch -exact -- $p {
* - "" {
if {$opt_roottype eq "list"} {
lappend keyset {*}[punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality
dict set pattern_this_structure $pattern_nest list
set keys [punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality
lappend keyset {*}$keys
lappend keyset_structure {*}[lrepeat [llength $keys] list]
dict set pattern_this_structure $p list
} elseif {$opt_roottype eq "dict"} {
lappend keyset {*}[dict keys $dval]
dict set pattern_this_structure $pattern_nest dict
set keys [dict keys $dval]
lappend keyset {*}$keys
lappend keyset_structure {*}[lrepeat [llength $keys] dict]
dict set pattern_this_structure $p dict
} else {
lappend keyset %string
dict set pattern_this_structure $pattern_nest string
lappend keyset_structure string
dict set pattern_this_structure $p string
}
}
%# {
dict set pattern_this_structure $pattern_nest string
dict set pattern_this_structure $p string
lappend keyset %#
lappend keyset_structure string
}
# {
dict set pattern_this_structure $pattern_nest list
dict set pattern_this_structure $p list
lappend keyset #
lappend keyset_structure list
}
## {
dict set pattern_this_structure $pattern_nest dict
dict set pattern_this_structure $p dict
lappend keyset [list ## query]
lappend keyset_structure dict
}
@* {
dict set pattern_this_structure $pattern_nest list
lappend keyset {*}[punk::lib::range 0 [llength $dval]-1]
puts ---->HERE<----
dict set pattern_this_structure $p list
set keys [punk::lib::range 0 [llength $dval]-1]
lappend keyset {*}$keys
lappend keyset_structure {*}[lrepeat [llength $keys] list]
}
@@ {
#get first k v from dict
dict set pattern_this_structure $pattern_nest dict
dict set pattern_this_structure $p dict
lappend keyset [list @@ query]
lappend keyset_structure dict
}
@*k@* - @*K@* {
#returns keys only
lappend keyset [list $p query]
dict set pattern_this_structure $pattern_nest dict
lappend keyset_structure dict
dict set pattern_this_structure $p dict
}
@*.@* {
lappend keyset {*}[dict keys $dval]
dict set pattern_this_structure $pattern_nest dict
set keys [dict keys $dval]
lappend keyset {*}$keys
lappend keyset_structure {*}[lrepeat [llength $keys] dict]
dict set pattern_this_structure $p dict
}
default {
#puts stderr "===p:$p"
#the basic scheme also doesn't allow commas in dict keys access via the convenience @@key - which isn't great, especially for arrays where it is common practice!
#we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful
#@@"key,etc" should allow any non-whitespace key
switch -glob -- $p {
{@k\*@*} - {@K\*@*} {
#value glob return keys
@ -728,72 +833,84 @@ namespace eval punk::lib {
# }
#}
lappend keyset [list $p query]
dict set pattern_this_structure $pattern_nest dict
lappend keyset_structure dict
dict set pattern_this_structure $p dict
}
@@* {
#exact match key - review - should raise error to match punk pipe behaviour?
set k [string range $p 2 end]
if {[dict exists $dval $k]} {
lappend keyset $k
lappend keyset_structure dict
}
dict set pattern_this_structure $pattern_nest dict
dict set pattern_this_structure $p dict
}
@k@* - @K@* {
set k [string range $p 3 end]
if {[dict exists $dval $k]} {
lappend keyset $k
lappend keyset_structure dict
}
dict set pattern_this_structure $pattern_nest dict
dict set pattern_this_structure $p dict
}
{@\*@*} {
#return list of values
#set k [string range $p 3 end]
#lappend keyset {*}[dict keys $dval $k]
lappend keyset [list $p query]
dict set pattern_this_structure $pattern_nest dict
lappend keyset_structure dict
dict set pattern_this_structure $p dict
}
{@\*.@*} {
set k [string range $p 4 end]
lappend keyset {*}[dict keys $dval $k]
dict set pattern_this_structure $pattern_nest dict
set keys [dict keys $dval $k]
lappend keyset {*}$keys
lappend keyset_structure {*}[lrepeat [llength $keys] dict]
dict set pattern_this_structure $p dict
}
{@v\*@*} - {@V\*@*} {
#value-glob return value
#error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'"
lappend keyset [list $p query]
dict set pattern_this_structure $pattern_nest dict
lappend keyset_structure dict
dict set pattern_this_structure $p dict
}
{@\*v@*} - {@\*V@*} {
#key-glob return value
lappend keyset [list $p query]
dict set pattern_this_structure $pattern_nest dict
lappend keyset_structure dict
dict set pattern_this_structure $p dict
}
{@\*@*} - {@\*v@*} - {@\*V@} {
#key glob return val
lappend keyset [list $p query]
dict set pattern_this_structure $pattern_nest dict
lappend keyset_structure dict
dict set pattern_this_structure $p dict
}
@??@* {
#exact key match - no error
lappend keyset [list $p query]
dict set pattern_this_structure $pattern_nest dict
lappend keyset_structure dict
dict set pattern_this_structure $p dict
}
default {
set this_type $opt_roottype
if {[string match @* $p]} {
#list mode - trim optional list specifier @
set p [string range $p 1 end]
dict set pattern_this_structure $pattern_nest list
dict set pattern_this_structure $p list
set this_type list
} elseif {[string match %* $p]} {
dict set pattern_this_structure $pattern_nest string
dict set pattern_this_structure $p string
lappend keyset $p
lappend keyset_structure string
set this_type string
}
if {$this_type eq "list"} {
dict set pattern_this_structure $pattern_nest list
dict set pattern_this_structure $p list
if {[string is integer -strict $p]} {
lappend keyset $p
lappend keyset_structure list
} elseif {[string match "?*-?*" $p]} {
#could be either - don't change type
#list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers
@ -828,17 +945,22 @@ namespace eval punk::lib {
#assert - upper >=0 because we have ruled out empty lists
}
#note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order
lappend keyset {*}[punk::lib::range $lower $upper]
set keys [punk::lib::range $lower $upper]
lappend keyset {*}$keys
lappend keyset_structure {*}[lrepeat [llength $keys] list]
} else {
lappend keyset [list @$p query]
lappend keyset_structure list
}
} elseif {$this_type eq "string"} {
dict set pattern_this_structure $pattern_nest string
dict set pattern_this_structure $p string
} elseif {$this_type eq "dict"} {
#default equivalent to @\*@*
dict set pattern_this_structure $pattern_nest dict
dict set pattern_this_structure $p dict
#puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]"
lappend keyset {*}[dict keys $dval $p]
set keys [dict keys $dval $p]
lappend keyset {*}$keys
lappend keyset_structure {*}[lrepeat [llength $keys] dict]
} else {
puts stderr "list: unrecognised pattern $p"
}
@ -846,12 +968,19 @@ namespace eval punk::lib {
}
}
}
}
# -- --- --- ---
#check next pattern for substructure type to use
#check next pattern-segment for substructure type to use
# -- --- --- ---
set substructure ""
set pnext [lindex $pattern_nest_list 1]
set pnext [lindex $segments 1]
set patterninfo [punk::_split_patterns $levelpatterns]
if {[llength $patterninfo] == 0} {
# // ? -review - what does this mean? for xpath this would mean at any level
set substructure [lindex $pattern_this_structure end]
} elseif {[llength $patterninfo] == 1} {
# single type in segment e.g /@@something/
switch -exact $pnext {
"" {
set substructure string
@ -870,7 +999,8 @@ namespace eval punk::lib {
}
* {
#set substructure $opt_roottype
set substructure [dict get $pattern_this_structure $pattern_nest]
#set substructure [dict get $pattern_this_structure $pattern_nest]
set substructure [lindex $pattern_this_structure end]
}
default {
switch -glob -- $pnext {
@ -885,11 +1015,17 @@ namespace eval punk::lib {
set substructure string
} else {
#set substructure $opt_roottype
set substructure [dict get $pattern_this_structure $pattern_nest]
#set substructure [dict get $pattern_this_structure $pattern_nest]
set substructure [lindex $pattern_this_structure end]
}
}
}
}
}
} else {
#e.g /@0,%str,.../
#doesn't matter what the individual types are - we have a list result
set substructure list
}
#puts "--pattern_nest: $pattern_nest substructure: $substructure"
dict set pattern_next_substructure $pattern_nest $substructure
@ -904,10 +1040,14 @@ namespace eval punk::lib {
}
}
if {$int_keyset} {
set keyset [lsort -integer $keyset]
set sortindices [lsort -indices -integer $keyset]
#set keyset [lsort -integer $keyset]
} else {
set keyset [lsort -$opt_keysorttype $keyset]
#set keyset [lsort -$opt_keysorttype $keyset]
set sortindices [lsort -indices -$opt_keysorttype $keyset]
}
set keyset [lmap i $sortindices {lindex $keyset $i}]
set keyset_structure [lmap i $sortindices {lindex $keyset_structure $i}]
}
foreach k $keyset {
@ -915,6 +1055,7 @@ namespace eval punk::lib {
}
lappend filtered_keys {*}$keyset
lappend all_keyset_structure {*}$keyset_structure
#puts stderr "--->pattern_nest:$pattern_nest keyset:$keyset"
}
@ -929,7 +1070,6 @@ namespace eval punk::lib {
#both keys and values could have newline characters.
#simple use of 'format' won't cut it for more complex dict keys/values
#use block::width or our columns won't align in some cases
set RST [a]
switch -- $opt_return {
"tailtohead" {
#last line of key is side by side (possibly with separator) with first line of value
@ -945,12 +1085,16 @@ namespace eval punk::lib {
set maxl [::tcl::mathfunc::max {*}[lmap v $display_keys {textblock::width $v}]]
set kidx 0
set last_hidekey 0
foreach keydisplay $display_keys key $filtered_keys {
set thisval "?"
set hidekey 0
set pattern_nest [lindex $pattern_key_index $kidx]
set pattern_nest_list [split $pattern_nest /]
#puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest"
set this_type [dict get $pattern_this_structure $pattern_nest]
#set this_type [dict get $pattern_this_structure $pattern_nest]
#set this_type [dict get $pattern_this_structure $key]
set this_type [lindex $all_keyset_structure $kidx]
#puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest this_type:$this_type"
set is_match 1 ;#whether to display the normal separator or bad-match separator
switch -- $this_type {
@ -1030,7 +1174,7 @@ namespace eval punk::lib {
}
}
string {
set hidekey 0
set hidekey 1
if {$key eq "%string"} {
set hidekey 1
set thisval $dval
@ -1043,11 +1187,21 @@ namespace eval punk::lib {
lassign [split $key -] _ extra
set width [expr {[textblock::width $dval] + $extra}]
set thisval [textblock::pad $dval -which left -width $width]
} elseif {[string match *lpadstr-* $key]} {
set hidekey 1
lassign [split $key -] _ extra
set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}]
set thisval [textblock::pad $dval -which left -width $width -padchar $extra]
} elseif {[string match *rpad-* $key]} {
set hidekey 1
lassign [split $key -] _ extra
set width [expr {[textblock::width $dval] + $extra}]
set thisval [textblock::pad $dval -which right -width $width]
} elseif {[string match *rpadstr-* $key]} {
set hidekey 1
lassign [split $key -] _ extra
set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}]
set thisval [textblock::pad $dval -which right -width $width -padchar $extra]
} else {
if {[lindex $key 1] eq "query"} {
set qry [lindex $key 0]
@ -1082,7 +1236,9 @@ namespace eval punk::lib {
lassign [textblock::size $thisval] _vw vwidth _vh vheight
#set blanks_above [string repeat \n [expr {$kheight -1}]]
set vblock $opt_ansibase_values$thisval$RST
append result [textblock::join_basic -- $vblock] \n
#append result [textblock::join_basic -- $vblock]
#review - we wouldn't need this space if we had a literal %sp %sp-x ??
append result " $vblock"
} else {
set ansibase_key [lindex $opt_ansibase_keys 0]
@ -1096,7 +1252,7 @@ namespace eval punk::lib {
if {$is_match} {
set use_sep $opt_sep
} else {
set use_sep " [a+ Web-red undercurly underline undert-white]mismatch[a] "
set use_sep $opt_mismatch_sep
}
@ -1105,8 +1261,12 @@ namespace eval punk::lib {
set sblock [textblock::pad $blanks_above$use_sep$blanks_below -width $sepwidth]
set vblock $blanks_above$opt_ansibase_values$thisval$RST
#only vblock is ragged - we can do a basic join because we don't care about rhs whitespace
if {$last_hidekey} {
append result \n
}
append result [textblock::join_basic -- $kblock $sblock $vblock] \n
}
set last_hidekey $hidekey
incr kidx
}
}

24
src/modules/punk/mix/base-0.1.tm

@ -351,8 +351,14 @@ namespace eval punk::mix::base {
continue
}
set testfolder [file join $candidate src $sub]
set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm]
if {[llength $tmfiles]} {
#ensure that if src/modules exists - it is always included even if empty
if {[string tolower $sub] eq "modules"} {
lappend tm_folders $testfolder
continue
}
#set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm]
#set podfolders [glob -nocomplain -dir $testfolder -type d -tail #modpod-*]
if {[llength [glob -nocomplain -dir $testfolder -type f -tail *.tm]] || [llength [glob -nocomplain -dir $testfolder -type d -tail #modpod-*]]} {
lappend tm_folders $testfolder
}
}
@ -428,9 +434,10 @@ namespace eval punk::mix::base {
}
#crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?)
# - try builtin zlib crc instead?
#sha1 is performant - and this is not being used in a cryptographic or adversarial context - so performance and practical unlikelihood of accidental collisions should be the main consideration.
#adler32 is fastest for some larger files of a few MB but slower on small files (possibly due to Tcl-based file load?)
#sha1 as at 2023 seems a good default
#sha1 as at 2023 seems a reasonable default
proc cksum_algorithms {} {
variable sha3_implementation
#sha2 is an alias for sha256
@ -459,10 +466,16 @@ namespace eval punk::mix::base {
#adler32 via file-slurp
proc cksum_adler32_file {filename} {
package require zlib; #should be builtin anyway
set data [punk::mix::util::fcat -translation binary $filename]
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename]
#set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names
zlib adler32 $data
}
#zlib crc vie file-slurp
proc cksum_crc_file {filename} {
package require zlib
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename]
zlib crc $data
}
#required to be able to accept relative paths
@ -614,6 +627,9 @@ namespace eval punk::mix::base {
package require cksum ;#tcllib
set cksum_command [list crc::cksum -format 0x%X -file]
}
crc {
set cksum_command [list cksum_crc_file]
}
adler32 {
set cksum_command [list cksum_adler32_file]
}

1119
src/modules/punk/mix/cli-999999.0a1.0.tm

File diff suppressed because it is too large Load Diff

3
src/modules/punk/mix/cli-buildversion.txt

@ -0,0 +1,3 @@
0.3.1
#First line must be a semantic version number
#all other lines are ignored.

5
src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm

@ -247,7 +247,8 @@ namespace eval punk::mix::commandset::loadedlib {
set projectdir [dict get $pathinfo closest]
if {$projectdir ne ""} {
set modulefolders [punk::mix::cli::lib::find_source_module_paths $projectdir]
foreach k [list modules vendormodules] {
set majorv [lindex [split [info tclversion] .] 0]
foreach k [list modules modules_tcl$majorv vendormodules vendormodules_tcl$majorv] {
set knownfolder [file join $projectdir src $k]
if {$knownfolder ni $modulefolders} {
lappend modulefolders $knownfolder
@ -261,7 +262,7 @@ namespace eval punk::mix::commandset::loadedlib {
#special case bootsupport/modules so it can be referred to as just bootsupport or bootsupport/modules
lappend modulefolders [file join $projectdir src bootsupport/modules]
if {$modulefoldername ni $mtails && $modulefoldername ni "bootsupport bootsupport/modules"} {
if {$modulefoldername ni $mtails && $modulefoldername ni "bootsupport bootsupport/modules bootsupport/modules_tcl$majorv"} {
set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n"
append msg "Known module folders: [lsort $mtails]\n"
append msg "Use a name from the above list, or a fully qualified path\n"

50
src/modules/punk/mix/commandset/module-999999.0a1.0.tm

@ -159,7 +159,7 @@ namespace eval punk::mix::commandset::module {
#set opts [dict merge $defaults $args]
#todo - review compatibility between -template and -type
#-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl)
#-type is the wrapping technology e.g 'plain' for none or tarjar or zip (modpod) etc (consider also snappy/snappy-tcl)
#-template may be a folder - but only if the selected -type suports it
@ -293,6 +293,7 @@ namespace eval punk::mix::commandset::module {
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_quiet [dict get $opts -quiet]
set opt_force [dict get $opts -force]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
@ -378,13 +379,39 @@ namespace eval punk::mix::commandset::module {
}
set template_filedata [string map $strmap $template_filedata]
set modulefile $modulefolder/${moduletail}-$infile_version.tm
if {[file exists $modulefile]} {
set errmsg "module.new error: module file $modulefile already exists - aborting"
if {[string match "*$magicversion*" $modulefile]} {
set tmfile $modulefolder/${moduletail}-$infile_version.tm
set podfile $modulefolder/#modpod-$moduletail-$infile_version/$moduletail-$infile_version.tm
set has_tm [file exists $tmfile]
set has_pod [file exists $podfile]
if {$has_tm && $has_pos} {
#invalid configuration - bomb out
error "module.new error: Invalid target configuration found. module folder has both a .tm file $tmfile and a modpod file $podfile. Please delete one of them before trying again."
}
if {$opt_type eq "plain"} {
set modulefile $tmfile
} else {
set modulefile $podfile
}
if {$has_tm || $has_pod} {
if {!$opt_force} {
if {$has_tm} {
set errmsg "module.new error: module file $tmfile already exists - aborting"
} else {
set errmsg "module.new error: module file $podfile already exists - aborting"
}
if {[string match "*$magicversion*" $tmfile]} {
append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm"
}
error $errmsg
} else {
#review - prompt here vs caller?
#we are committed to overwriting/replacing if there was a pre-existing module of same version
if {$has_pod} {
file delete -force [file dirname $podfile]
} elseif {$has_tm} {
file delete -force $tmfile
}
}
}
@ -407,13 +434,20 @@ namespace eval punk::mix::commandset::module {
}
}
set existing_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm]
set existing_tm_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm]
#it shouldn't be possible to overmatch with the glob - because '-' is not valid in a Tcl module name
set existing_pod_versions [glob -nocomplain -dir $modulefolder -tails #modpod-$moduletail-*]
set existing_versions [concat $existing_tm_versions $existing_pod_versions]
if {[llength $existing_versions]} {
set name_version_pairs [list]
lappend name_version_pairs [list $moduletail $infile_version]
foreach existing $existing_versions {
lappend name_version_pairs [punk::mix::cli::lib::split_modulename_version $existing] ;# .tm is stripped and ignored
lassign [punk::mix::cli::lib::split_modulename_version $existing] namepart version ;# .tm is stripped and ignored
if {[string match #modpod-* $namepart]} {
set namepart [string range $namepart 8 end]
}
lappend name_version_pairs [list $namepart $version]
}
set name_version_pairs [lsort -command {package vcompare} -index 1 $name_version_pairs] ;#while plain lsort will often work with versions - it can get order wrong with some - so use package vcompare
if {[lindex $name_version_pairs end] ne [list $moduletail $infile_version]} {
@ -436,6 +470,8 @@ namespace eval punk::mix::commandset::module {
if {!$opt_quiet} {
puts stdout "Creating $modulefile from template $moduletemplate"
}
file mkdir [file dirname $modulefile]
set fd [open $modulefile w]
fconfigure $fd -translation binary
puts -nonewline $fd $template_filedata

26
src/modules/punk/mix/commandset/project-999999.0a1.0.tm

@ -320,6 +320,8 @@ namespace eval punk::mix::commandset::project {
puts stderr "-force 1 or -update 1 not specified - aborting"
return
}
#review
set fossil_repo_file $repodb_folder/$projectname.fossil
}
if {$fossil_repo_file eq ""} {
@ -415,12 +417,30 @@ namespace eval punk::mix::commandset::project {
if {[file exists $projectdir/src/modules]} {
foreach m $opt_modules {
if {![file exists $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm]} {
#check if mod-ver.tm file or #modpod-mod-ver folder exist
set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm
set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm
set has_tm [file exists $tmfile]
set has_pod [file exists $podfile]
#puts stderr "=====> has_tm: $has_tm has_pod: $has_pod"
if {!$has_tm && !$has_pod} {
#todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc
punk::mix::commandset::module::new $m -project $projectname -type $opt_type
punk::mix::commandset::module::new -project $projectname -type $opt_type $m
} else {
#we should rarely if ever want to force any src/modules to be overwritten
if {$opt_force} {
punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force 1
if {$has_pod} {
set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"]
set overwrite_type zip
} else {
set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"]
set overwrite_type $opt_type
}
if {[string tolower $answer] eq "y"} {
#REVIEW - all pods zip - for now
punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m
}
}
}
}

102
src/modules/punk/mix/templates/layouts/project/src/make.tcl

@ -13,7 +13,7 @@ namespace eval ::punkmake {
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list]
variable non_help_flags [list -k]
variable help_flags [list -help --help /?]
variable known_commands [list project get-project-info shell bootsupport]
variable known_commands [list project get-project-info shell vendor bootsupport]
}
if {"::try" ni [info commands ::try]} {
puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting"
@ -134,6 +134,8 @@ proc punkmake_gethelp {args} {
append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n \n
append h " $scriptname bootsupport" \n
append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n \n
append h " $scriptname vendor" \n
append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n
append h " $scriptname get-project-info" \n
append h " - show the name and base folder of the project to be built" \n
append h "" \n
@ -251,6 +253,100 @@ if {$::punkmake::command eq "shell"} {
exit 1
}
if {$::punkmake::command eq "vendor"} {
puts "projectroot: $projectroot"
puts "script: [info script]"
#puts "-- [tcl::tm::list] --"
puts stdout "Updating vendor modules"
proc vendor_localupdate {projectroot} {
set local_modules [list]
set git_modules [list]
set fossil_modules [list]
#todo vendor/lib ?
set vendor_config $projectroot/src/vendormodules/include_modules.config
if {[file exists $vendor_config]} {
set targetroot $projectroot/src/vendormodules/modules
source $vendor_config ;#populate $local_modules $git_modules $fossil_modules with project-specific list
if {![llength $local_modules]} {
puts stderr "No local vendor modules configured for updating (config file: $vendor_config)"
} else {
if {[catch {
#----------
set vendor_installer [punkcheck::installtrack new make.tcl $projectroot/src/vendormodules/.punkcheck]
$vendor_installer set_source_target $projectroot $projectroot/src/vendormodules
set installation_event [$vendor_installer start_event {-make_step vendor}]
#----------
} errM]} {
puts stderr "Unable to use punkcheck for vendor update. Error: $errM"
set installation_event ""
}
foreach {relpath module} $local_modules {
set module [string trim $module :]
set module_subpath [string map {:: /} [namespace qualifiers $module]]
set srclocation [file join $projectroot $relpath $module_subpath]
#puts stdout "$relpath $module $module_subpath $srclocation"
set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*]
#lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1
if {![llength $pkgmatches]} {
puts stderr "Missing source for vendor module $module - not found in $srclocation"
continue
}
set latestfile [lindex $pkgmatches 0]
set latestver [lindex [split [file rootname $latestfile] -] 1]
foreach m $pkgmatches {
lassign [split [file rootname $m] -] _pkg ver
#puts "comparing $ver vs $latestver"
if {[package vcompare $ver $latestver] == 1} {
set latestver $ver
set latestfile $m
}
}
set srcfile [file join $srclocation $latestfile]
set tgtfile [file join $targetroot $module_subpath $latestfile]
if {$installation_event ne ""} {
#----------
$installation_event targetset_init INSTALL $tgtfile
$installation_event targetset_addsource $srcfile
#----------
if {\
[llength [dict get [$installation_event targetset_source_changes] changed]]\
|| [llength [$installation_event get_targets_exist]] < [llength [$installation_event get_targets]]\
} {
file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists
$installation_event targetset_started
# -- --- --- --- --- ---
puts "VENDOR update: $srcfile -> $tgtfile"
if {[catch {
file copy -force $srcfile $tgtfile
} errM]} {
$installation_event targetset_end FAILED
} else {
$installation_event targetset_end OK
}
# -- --- --- --- --- ---
} else {
puts -nonewline stderr "."
$installation_event targetset_end SKIPPED
}
$installation_event end
} else {
file copy -force $srcfile $tgtfile
}
}
}
} else {
puts stderr "No config at $vendor_config - nothing configured to update"
}
}
puts stdout " vendor package update done "
flush stderr
flush stdout
::exit 0
}
if {$::punkmake::command eq "bootsupport"} {
puts "projectroot: $projectroot"
puts "script: [info script]"
@ -275,7 +371,7 @@ if {$::punkmake::command eq "bootsupport"} {
set boot_event [$boot_installer start_event {-make_step bootsupport}]
#----------
} errM]} {
puts stderr "Unable to use punkcheck for bootsupport error: $errM"
puts stderr "Unable to use punkcheck for bootsupport. Error: $errM"
set boot_event ""
}
@ -441,7 +537,7 @@ if {[file exists $sourcefolder/vendorlib]} {
if {[file exists $sourcefolder/vendormodules]} {
#install .tm *and other files*
puts stdout "VENDORMODULES: copying from $sourcefolder/vendormodules to $target_modules_base (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md}]
set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
} else {
puts stderr "VENDORMODULES: No src/vendormodules folder found."

53
src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl

@ -0,0 +1,53 @@
apply {code {
set scriptpath [file normalize [info script]]
if {[string match "#modpod-loadscript*.tcl" [file tail $scriptpath]]} {
#jump up an extra dir level if we are within a #modpod-loadscript file.
set mypath [file dirname [file dirname $scriptpath]]
#expect to be in folder #modpod-<module>-<ver>
#Now we need to test if we are in a mounted folder vs an extracted folder
set container [file dirname $mypath]
if {[string match "#mounted-modpod-*" $container]} {
set mypath [file dirname $container]
}
set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #modpod-<module>-<ver>
} else {
set mypath [file dirname $scriptpath]
set modver [file root [file tail [info script]]]
}
set mysegs [file split $mypath]
set overhang [list]
foreach libpath [tcl::tm::list] {
set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & /
if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} {
#mypath is below libpath
set overhang [lrange $mysegs [llength $libsegs]+1 end]
break
}
}
lassign [split $modver -] moduletail version
set ns [join [concat $overhang $moduletail] ::]
#if {![catch {package require modpod}]} {
# ::modpod::disconnect [info script]
#}
package provide $ns $version
namespace eval $ns $code
} ::} {
#
# Module procs here, where current namespace is that of the module.
# Package version can, if needed, be accessed as [uplevel 1 {set version}]
# Last element of module name: [uplevel 1 {set moduletail}]
# Full module name: [uplevel 1 {set ns}]
#<modulecode>
#
#</modulecode>
#<sourcefiles>
#
#</sourcefiles>
#<loadfiles>
#
#</loadfiles>
}

2
src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/z

@ -0,0 +1,2 @@
#Do not remove the trailing ctrl-z character from this file


BIN
src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip

Binary file not shown.

3
src/modules/punk/path-999999.0a1.0.tm

@ -217,7 +217,8 @@ namespace eval punk::path {
-directory -default "\uFFFF"
-call-depth-internal -default 0 -type integer
-antiglob_paths -default {}
*values -min 0 -max -1 -type string
*values -min 0 -max -1 -optional 1 -type string
tailglobs -multiple 1
} $args]
lassign [dict values $argd] opts values
set tailglobs [dict values $values]

12
src/modules/punk/repl-0.1.tm

@ -685,7 +685,7 @@ proc repl::rputs {args} {
set last_char_info_width 60
#review - string shouldn't be truncated prior to stripcodes - could chop ansi codes!
#set summary "[::shellfilter::ansi::stripcodes [string range $out 0 $last_char_info_width]]"
set out_plain_text [punk::ansi::stripansi $out]
set out_plain_text [punk::ansi::ansistrip $out]
set summary [string range $out_plain_text 0 $last_char_info_width]
if {[string length $summary] > $last_char_info_width} {
append summary " ..."
@ -842,7 +842,7 @@ namespace eval punk::repl::class {
#append combined \n
append new0 \n
}
set underlay [punk::ansi::stripansi $activeline]
set underlay [punk::ansi::ansistrip $activeline]
set line_nextchar_col [expr {[punk::char::string_width $underlay] + 1}]
if {$o_cursor_col > $line_nextchar_col} {
set o_cursor_col $line_nextchar_col
@ -1103,7 +1103,7 @@ namespace eval punk::repl::class {
set suffix [string repeat " " [expr {$linecols -$col1}]]
#capitalised INDEX - for grapheme/control-char index e.g a with diacritic a\u0300 has a single index
set char_at_cursor [ansistring INDEX $cursorline $charindex_at_cursor] ;#this is the char with appropriate ansireset codes
set rawchar [punk::ansi::stripansi $char_at_cursor]
set rawchar [punk::ansi::ansistrip $char_at_cursor]
if {$rawchar eq " "} {
set charhighlight "[punk::ansi::a+ White]_[a]"
} else {
@ -1865,7 +1865,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
}
if {[string match "\x1b*" $line]} {
rputs stderr "${debugprompt}esc - '[punk::ansi::ansistring::VIEW $line]'"
#set commandstr [punk::ansi::stripansi $commandstr]
#set commandstr [punk::ansi::ansistrip $commandstr]
}
}
@ -2069,8 +2069,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
#screen_last_char_add [string index $lastoutchar_codethread$lasterrchar_codethread end] "stdout/stderr"
#set lastoutchar [string index [punk::ansi::stripansi $::repl::output_stdout] end]
#set lasterrchar [string index [punk::ansi::stripansi $::repl::output_stderr] end]
#set lastoutchar [string index [punk::ansi::ansistrip $::repl::output_stdout] end]
#set lasterrchar [string index [punk::ansi::ansistrip $::repl::output_stderr] end]
#to determine whether cursor is back at col0 of newline
#screen_last_char_add [string index $lastoutchar$lasterrchar end] "stdout/stderr"

4
src/modules/punk/repl/codethread-999999.0a1.0.tm

@ -177,8 +177,8 @@ tcl::namespace::eval punk::repl::codethread {
#interp transfer code $errhandle ""
#flush $errhandle
set lastoutchar [string index [punk::ansi::stripansi $output_stdout] end]
set lasterrchar [string index [punk::ansi::stripansi $output_stderr] end]
set lastoutchar [string index [punk::ansi::ansistrip $output_stdout] end]
set lasterrchar [string index [punk::ansi::ansistrip $output_stderr] end]
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]"
set tid [thread::id]

9
src/modules/punk/repo-999999.0a1.0.tm

@ -1447,6 +1447,7 @@ namespace eval punk::repo {
#Must accept empty prefix - which is effectively noop.
#MUCH faster version for absolute path prefix (pre-normalized)
#review - will error on file join if lrange returns empty list ie if prefix longer than path
proc path_strip_alreadynormalized_prefixdepth {path prefix} {
if {$prefix eq ""} {
return $path
@ -1488,11 +1489,11 @@ namespace eval punk::repo {
interp alias {} git_revision {} ::punk::repo::git_revision
interp alias {} gs {} git status -sb
interp alias {} gs {} shellrun::runconsole git status -sb
interp alias {} gr {} ::punk::repo::git_revision
interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console
interp alias {} glast {} git log -1 HEAD --stat
interp alias {} gconf {} git config --global -l
interp alias {} gl {} shellrun::runconsole git log --oneline --decorate ;#decorate so stdout consistent with what we see on console
interp alias {} glast {} shellrun::runconsole git log -1 HEAD --stat
interp alias {} gconf {} shellrun::runconsole git config --global -l
}
namespace eval punk::repo::lib {

632
src/modules/punk/zip-999999.0a1.0.tm

@ -0,0 +1,632 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024 JMN
# (C) 2009 Path Thoyts <patthyts@users.sourceforge.net>
#
# @@ Meta Begin
# Application punk::zip 999999.0a1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::zip 0 999999.0a1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require punk::zip]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::zip
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::zip
#[list_begin itemized]
package require Tcl 8.6-
package require punk::args
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package {punk::args}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::zip::class {
#*** !doctools
#[subsection {Namespace punk::zip::class}]
#[para] class definitions
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::zip {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
#*** !doctools
#[subsection {Namespace punk::zip}]
#[para] Core API functions for punk::zip
#[list_begin definitions]
proc Path_a_atorbelow_b {path_a path_b} {
return [expr {[StripPath $path_b $path_a] ne $path_a}]
}
proc Path_a_at_b {path_a path_b} {
return [expr {[StripPath $path_a $path_b] eq "." }]
}
proc Path_strip_alreadynormalized_prefixdepth {path prefix} {
if {$prefix eq ""} {
return $path
}
set pathparts [file split $path]
set prefixparts [file split $prefix]
if {[llength $prefixparts] >= [llength $pathparts]} {
return ""
}
return [file join \
{*}[lrange \
$pathparts \
[llength $prefixparts] \
end]]
}
#StripPath - borrowed from tcllib fileutil
# ::fileutil::stripPath --
#
# If the specified path references/is a path in prefix (or prefix itself) it
# is made relative to prefix. Otherwise it is left unchanged.
# In the case of it being prefix itself the result is the string '.'.
#
# Arguments:
# prefix prefix to strip from the path.
# path path to modify
#
# Results:
# path The (possibly) modified path.
if {[string equal $tcl_platform(platform) windows]} {
# Windows. While paths are stored with letter-case preserved al
# comparisons have to be done case-insensitive. For reference see
# SF Tcllib Bug 2499641.
proc StripPath {prefix path} {
# [file split] is used to generate a canonical form for both
# paths, for easy comparison, and also one which is easy to modify
# using list commands.
set prefix [file split $prefix]
set npath [file split $path]
if {[string equal -nocase $prefix $npath]} {
return "."
}
if {[string match -nocase "${prefix} *" $npath]} {
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]]
}
return $path
}
} else {
proc StripPath {prefix path} {
# [file split] is used to generate a canonical form for both
# paths, for easy comparison, and also one which is easy to modify
# using list commands.
set prefix [file split $prefix]
set npath [file split $path]
if {[string equal $prefix $npath]} {
return "."
}
if {[string match "${prefix} *" $npath]} {
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]]
}
return $path
}
}
proc Timet_to_dos {time_t} {
#*** !doctools
#[call] [fun Timet_to_dos] [arg time_t]
#[para] convert a unix timestamp into a DOS timestamp for ZIP times.
#[example {
# DOS timestamps are 32 bits split into bit regions as follows:
# 24 16 8 0
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+
#}]
set s [clock format $time_t -format {%Y %m %e %k %M %S}]
scan $s {%d %d %d %d %d %d} year month day hour min sec
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16)
| ($hour << 11) | ($min << 5) | ($sec >> 1)}
}
proc walk {args} {
#*** !doctools
#[call] [fun walk] [arg ?options?] [arg base]
#[para] Walk a directory tree rooted at base
#[para] the -excludes list can be a set of glob expressions to match against files and avoid
#[para] e.g
#[example {
# punk::zip::walk -exclude {CVS/* *~.#*} library
#}]
set argd [punk::args::get_dict {
*proc -name punk::zip::walk
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default ""
*values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
} $args]
set base [dict get $argd values base]
set fileglobs [dict get $argd values fileglobs]
set subpath [dict get $argd opts -subpath]
set excludes [dict get $argd opts -excludes]
set imatch [list]
foreach fg $fileglobs {
lappend imatch [file join $subpath $fg]
}
set result {}
#set imatch [file join $subpath $match]
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch]
foreach file $files {
set excluded 0
foreach glob $excludes {
if {[string match $glob $file]} {
set excluded 1
break
}
}
if {!$excluded} {lappend result $file}
}
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] {
set subdir [walk -subpath $dir -excludes $excludes $base {*}$fileglobs]
if {[llength $subdir]>0} {
set result [concat $result $dir $subdir]
}
}
return $result
}
# Mkzipfile --
#
# FIX ME: should handle the current offset for non-seekable channels
#
proc Mkzipfile {zipchan base path {comment ""}} {
#*** !doctools
#[call] [fun Mkzipfile] [arg zipchan] [arg base] [arg path] [arg ?comment?]
#[para] Add a single file to a zip archive
#[para] The zipchan channel should already be open and binary.
#[para] You can provide a -comment for the file.
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive.
set fullpath [file join $base $path]
set mtime [Timet_to_dos [file mtime $fullpath]]
set utfpath [encoding convertto utf-8 $path]
set utfcomment [encoding convertto utf-8 $comment]
set flags [expr {(1<<11)}] ;# utf-8 comment and path
set method 0 ;# store 0, deflate 8
set attr 0 ;# text or binary (default binary)
set version 20 ;# minumum version req'd to extract
set extra ""
set crc 0
set size 0
set csize 0
set data ""
set seekable [expr {[tell $zipchan] != -1}]
if {[file isdirectory $fullpath]} {
set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx)
#set attrex 0x40000010
} elseif {[file executable $fullpath]} {
set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx)
} else {
set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-)
if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} {
set attr 1 ;# text
}
}
if {[file isfile $fullpath]} {
set size [file size $fullpath]
if {!$seekable} {set flags [expr {$flags | (1 << 3)}]}
}
set offset [tell $zipchan]
set local [binary format a4sssiiiiss PK\03\04 \
$version $flags $method $mtime $crc $csize $size \
[string length $utfpath] [string length $extra]]
append local $utfpath $extra
puts -nonewline $zipchan $local
if {[file isfile $fullpath]} {
# If the file is under 2MB then zip in one chunk, otherwize we use
# streaming to avoid requiring excess memory. This helps to prevent
# storing re-compressed data that may be larger than the source when
# handling PNG or JPEG or nested ZIP files.
if {$size < 0x00200000} {
set fin [open $fullpath rb]
set data [read $fin]
set crc [zlib crc32 $data]
set cdata [zlib deflate $data]
if {[string length $cdata] < $size} {
set method 8
set data $cdata
}
close $fin
set csize [string length $data]
puts -nonewline $zipchan $data
} else {
set method 8
set fin [open $fullpath rb]
set zlib [zlib stream deflate]
while {![eof $fin]} {
set data [read $fin 4096]
set crc [zlib crc32 $data $crc]
$zlib put $data
if {[string length [set zdata [$zlib get]]]} {
incr csize [string length $zdata]
puts -nonewline $zipchan $zdata
}
}
close $fin
$zlib finalize
set zdata [$zlib get]
incr csize [string length $zdata]
puts -nonewline $zipchan $zdata
$zlib close
}
if {$seekable} {
# update the header if the output is seekable
set local [binary format a4sssiiii PK\03\04 \
$version $flags $method $mtime $crc $csize $size]
set current [tell $zipchan]
seek $zipchan $offset
puts -nonewline $zipchan $local
seek $zipchan $current
} else {
# Write a data descriptor record
set ddesc [binary format a4iii PK\7\8 $crc $csize $size]
puts -nonewline $zipchan $ddesc
}
}
#PK\x01\x02 Cdentral directory file header
#set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3
set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems)
set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \
$version $flags $method $mtime $crc $csize $size \
[string length $utfpath] [string length $extra]\
[string length $utfcomment] 0 $attr $attrex $offset]
append hdr $utfpath $extra $utfcomment
return $hdr
}
# zip::mkzip --
#
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt
#
proc mkzip {args} {
#*** !doctools
#[call] [fun mkzip] [arg ?options?] [arg filename]
#[para] Create a zip archive in 'filename'
#[para] If a file already exists, an error will be raised.
set argd [punk::args::get_dict {
*proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'"
*opts
-return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive
the option -return pretty is the default and uses the punk::lib pdict/plist system
to return a formatted list for the terminal
"
-zipkit -default 0 -type none -help ""
-runtime -default "" -help "specify a prefix file
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip
will create a self-extracting zip archive from the subdir/ folder.
"
-comment -default "" -help "An optional comment for the archive"
-directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided"
-base -default "" -help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory"
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"}
*values -min 1 -max -1
filename -default "" -help "name of zipfile to create"
globs -default {*} -multiple 1 -help "list of glob patterns to match.
Only directories with matching files will be included in the archive"
} $args]
set filename [dict get $argd values filename]
if {$filename eq ""} {
error "mkzip filename cannot be empty string"
}
if {[regexp {[?*]} $filename]} {
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name
error "mkzip filename should not contain glob characters ? *"
}
if {[file exists $filename]} {
error "mkzip filename:$filename already exists"
}
dict for {k v} [dict get $argd opts] {
switch -- $k {
-comment {
dict set argd opts $k [encoding convertto utf-8 $v]
}
-directory - -base {
dict set argd opts $k [file normalize $v]
}
}
}
array set opts [dict get $argd opts]
if {$opts(-directory) ne ""} {
if {$opts(-base) ne ""} {
#-base and -directory have been normalized already
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} {
error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)"
}
set base $opts(-base)
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)]
} else {
set base $opts(-directory)
set relpath ""
}
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]]
set norm_filename [file normalize $filename]
set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning)
if {[Path_a_atorbelow_b $norm_filename $norm_dir]} {
#check that we aren't adding the zipfile to itself
#REVIEW - now that we open zipfile after scanning - this isn't really a concern!
#keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?)
#In the case of -force - we may want to delay replacement of original until scan is done?
#try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each
#1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths
set self_globs_match 0
foreach g [dict get $argd values globs] {
if {[string match $g [file tail $filename]]} {
set self_globs_match 1
break
}
}
if {$self_globs_match} {
#still dangerous
set self_excluded 0
foreach e $opts(-exclude) {
if {[string match $e [file tail $filename]]} {
set self_excluded 1
break
}
}
if {!$self_excluded} {
#still dangerous - likely to be in resultset - check each path
#puts stderr "zip file $filename is below directory $opts(-directory)"
set self_is_matched 0
set i 0
foreach p $paths {
set norm_p [file normalize [file join $opts(-directory) $p]]
if {[Path_a_at_b $norm_filename $norm_p]} {
set self_is_matched 1
break
}
incr i
}
if {$self_is_matched} {
puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message"
set paths [lremove $paths $i]
}
}
}
}
} else {
set paths [list]
set dir [pwd]
if {$opts(-base) ne ""} {
if {![Path_a_atorbelow_b $dir $opts(-base)]} {
error "punk::zip::mkzip -base $opts(-base) must be above current directory"
}
set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]]
} else {
set relpath ""
}
set base $opts(-base)
set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]]
foreach m $matches {
if {$m eq $filename} {
#puts stderr "--> excluding $filename"
continue
}
set isok 1
foreach e [concat $opts(-exclude) $filename] {
if {[string match $e $m]} {
set isok 0
break
}
}
if {$isok} {
lappend paths [file join $relpath $m]
}
}
}
if {![llength $paths]} {
return ""
}
set zf [open $filename wb]
if {$opts(-runtime) ne ""} {
set rt [open $opts(-runtime) rb]
fcopy $rt $zf
close $rt
} elseif {$opts(-zipkit)} {
set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n"
append zkd "package require vfs::zip\n"
append zkd "vfs::zip::Mount \[info script\] \[info script\]\n"
append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n"
append zkd " source \[file join \[info script\] main.tcl\]\n"
append zkd "}\n"
append zkd \x1A
puts -nonewline $zf $zkd
}
set count 0
set cd ""
set members [list]
foreach path $paths {
#puts $path
lappend members $path
append cd [Mkzipfile $zf $base $path] ;#path already includes relpath
incr count
}
set cdoffset [tell $zf]
set endrec [binary format a4ssssiis PK\05\06 0 0 \
$count $count [string length $cd] $cdoffset\
[string length $opts(-comment)]]
append endrec $opts(-comment)
puts -nonewline $zf $cd
puts -nonewline $zf $endrec
close $zf
set result ""
switch -exact -- $opts(-return) {
list {
set result $members
}
pretty {
if {[info commands showlist] ne ""} {
set result [plist -channel none members]
} else {
set result $members
}
}
none {
set result ""
}
}
return $result
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::zip ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::zip::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::zip::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::zip::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::zip::system {
#*** !doctools
#[subsection {Namespace punk::zip::system}]
#[para] Internal functions that are not part of the API
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::zip [tcl::namespace::eval punk::zip {
variable pkg punk::zip
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]

3
src/modules/punk/zip-buildversion.txt

@ -0,0 +1,3 @@
0.1.0
#First line must be a semantic version number
#all other lines are ignored.

6
src/modules/punkcheck-0.1.0.tm

@ -37,7 +37,7 @@ namespace eval punkcheck {
start_installer_event installfile_*
#antiglob_dir & antiglob_file entries match the pattern at any level - should not contain path separators
variable default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"]
variable default_antiglob_dir_core [list "#*" "_aside" "_build" ".git" ".fossil*"]
variable default_antiglob_file_core ""
proc uuid {} {
set has_twapi 0
@ -1196,7 +1196,7 @@ namespace eval punkcheck {
#and may be less error prone than doing slightly more opaue path manipulations at each recursion level to determine where we started
#For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one.
set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDPEPTH = 0
set max_depth [dict get $opts -max_depth]
set max_depth [dict get $opts -max_depth] ;# -1 for no limit
set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill
set fileglob [dict get $opts -glob]
set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting
@ -1598,7 +1598,7 @@ namespace eval punkcheck {
}
if {$CALLDEPTH >= $max_depth} {
if {$max_depth != -1 && $CALLDEPTH >= $max_depth} {
#don't process any more subdirs
set subdirs [list]
} else {

9
src/modules/shellfilter-0.1.9.tm

@ -135,8 +135,9 @@ namespace eval shellfilter::pipe {
namespace eval shellfilter::ansi {
#maint warning -
#stripansi from punk::ansi is better/more comprehensive
#ansistrip from punk::ansi is better/more comprehensive
proc stripcodes {text} {
#obsolete?
#single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~).
dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"]
#dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic
@ -522,7 +523,7 @@ namespace eval shellfilter::chan {
#review - we should probably provide a more narrow filter than only strips color - and one that strips most(?)
# - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?)
#punk::ansi::stripansi converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion
#punk::ansi::ansistrip converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion
#assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations!
oo::class create ansistrip {
variable o_trecord
@ -554,7 +555,7 @@ namespace eval shellfilter::chan {
}
method read {transform_handle bytes} {
set instring [encoding convertfrom $o_enc $bytes]
set outstring [punk::ansi::stripansi $instring]
set outstring [punk::ansi::ansistrip $instring]
return [encoding convertto $o_enc $outstring]
}
method flush {transform_handle} {
@ -562,7 +563,7 @@ namespace eval shellfilter::chan {
}
method write {transform_handle bytes} {
set instring [encoding convertfrom $o_enc $bytes]
set outstring [punk::ansi::stripansi $instring]
set outstring [punk::ansi::ansistrip $instring]
return [encoding convertto $o_enc $outstring]
}
method meta_is_redirection {} {

36
src/modules/shellrun-0.1.1.tm

@ -178,6 +178,41 @@ namespace eval shellrun {
return $exitinfo
}
#run in the way tcl unknown does - but without regard to auto_noexec
proc runconsole {args} {
if {![llength $args]} {
error "no commandline specified"
return
}
set name [lindex $args 0]
set new [auto_execok $name]
set repl_runid [punk::get_repl_runid]
#set ::punk::last_run_display [list]
set redir ">&@stdout <@stdin"
uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions]
#we can't detect stdout/stderr output from the exec
#for now emit an extra \n on stderr
#todo - there is probably no way around this but to somehow exec in the context of a completely separate console
#This is probably a tricky problem - especially to do cross-platform
#
# - use [dict get $::tcl::UnknownOptions -code] (0|1) exit
if {[dict get $::tcl::UnknownOptions -code] == 0} {
set c green
set m "ok"
} else {
set c yellow
set m "errorCode $::errorCode"
}
set chunklist [list]
lappend chunklist [list "info" "[a $c]$m[a] " ]
if {$repl_runid != 0} {
tsv::lappend repl runchunks-$repl_runid {*}$chunklist
}
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
proc runout {args} {
#set_last_run_display [list]
variable runout
@ -720,6 +755,7 @@ namespace eval shellrun {
interp alias {} runx {} shellrun::runx
interp alias {} sh_runx {} shellrun::sh_runx
interp alias {} runc {} shellrun::runconsole
interp alias {} runraw {} shellrun::runraw

93
src/modules/textblock-999999.0a1.0.tm

@ -3840,21 +3840,24 @@ tcl::namespace::eval textblock {
}
set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I]
set ansi [a+ {*}$fc web-black Web-lightgreen]
#set ansi [a+ {*}$fc web-black Web-lightgreen]
set ansi [a+ {*}$fc black Term-113]
set val [list ansi $ansi cat reactive_nonmetal]
foreach e $cat_reactive_nonmetal {
tcl::dict::set ecat $e $val
}
set cat [list Li Na K Rb Cs Fr]
set ansi [a+ {*}$fc web-black Web-Khaki]
#set ansi [a+ {*}$fc web-black Web-Khaki]
set ansi [a+ {*}$fc black Term-lightgoldenrod2]
set val [list ansi $ansi cat alkali_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs]
set ansi [a+ {*}$fc web-black Web-lightsalmon]
#set ansi [a+ {*}$fc web-black Web-lightsalmon]
set ansi [a+ {*}$fc black Term-orange1]
set val [list ansi $ansi cat transition_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -3868,7 +3871,8 @@ tcl::namespace::eval textblock {
}
set cat [list B Si Ge As Sb Te At]
set ansi [a+ {*}$fc web-black Web-turquoise]
#set ansi [a+ {*}$fc web-black Web-turquoise]
set ansi [a+ {*}$fc black Brightcyan]
set val [list ansi $ansi cat metalloids]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -3889,7 +3893,8 @@ tcl::namespace::eval textblock {
}
set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu]
set ansi [a+ {*}$fc web-black Web-tan]
#set ansi [a+ {*}$fc web-black Web-tan]
set ansi [a+ {*}$fc black Term-tan]
set val [list ansi $ansi cat lanthanoids]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -3944,15 +3949,19 @@ tcl::namespace::eval textblock {
$t configure \
-frametype_header light\
-ansiborder_header [a+ {*}$fc web-white]\
-ansibase_header [a+ {*}$fc Web-black]\
-ansibase_body [a+ {*}$fc Web-black]\
-ansiborder_body [a+ {*}$fc web-black]\
-ansiborder_header [a+ {*}$fc brightwhite]\
-ansibase_header [a+ {*}$fc Black]\
-ansibase_body [a+ {*}$fc Black]\
-ansiborder_body [a+ {*}$fc black]\
-frametype block
#-ansiborder_header [a+ {*}$fc web-white]\
if {$opt_return eq "table"} {
if {[dict get $opts -frame]} {
set output [textblock::frame -ansiborder [a+ {*}$fc Web-black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Web-black] Periodic Table " [$t print]]
#set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]]
#set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]]
set output [textblock::frame -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]]
} else {
set output [$t print]
}
@ -4260,8 +4269,8 @@ tcl::namespace::eval textblock {
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
if {[punk::ansi::ta::detect $textblock]} {
#stripansiraw slightly faster than stripansi - and won't affect width (avoid detect_g0/conversions)
set textblock [punk::ansi::stripansiraw $textblock]
#ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions)
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]]
@ -4277,7 +4286,7 @@ tcl::namespace::eval textblock {
set tl $textblock
}
if {[punk::ansi::ta::detect $tl]} {
set tl [punk::ansi::stripansiraw $tl]
set tl [punk::ansi::ansistripraw $tl]
}
return [punk::char::ansifreestring_width $tl]
}
@ -4312,9 +4321,9 @@ tcl::namespace::eval textblock {
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#stripansiraw on entire block in one go rather than line by line - result should be the same - review - make tests
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::stripansiraw $textblock]
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
@ -4343,16 +4352,16 @@ tcl::namespace::eval textblock {
}
set block [textutil::tabify::untabify2 $block $tw]
if {[tcl::string::last \n $block] >= 0} {
return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [stripansi $v]}]]
return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]]
}
if {[catch {llength $block}]} {
return [::punk::char::string_width [stripansi $block]]
return [::punk::char::string_width [ansistrip $block]]
}
if {[llength $block] == 0} {
#could be just a whitespace string
return [tcl::string::length $block]
}
return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [stripansi $v]}]]
return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]]
}
#we shouldn't make textblock depend on the punk pipeline system
@ -4433,9 +4442,21 @@ tcl::namespace::eval textblock {
set lines [list]
set padcharsize [punk::ansi::printing_length $padchar]
set pad_has_ansi [punk::ansi::ta::detect $padchar]
if {$block eq ""} {
#we need to treat as a line
return [tcl::string::repeat $padchar $width]
set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width
#TODO
#review - what happens when padchar has ansi, or the width would split a double-wide unicode char?
#we shouldn't be using string range if there is ansi - (overtype? ansistring range?)
#we should use overtype with suitable replacement char (space?) for chopped double-wides
if {!$pad_has_ansi} {
return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1]
} else {
set base [tcl::string::repeat " " $width]
return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]]
}
}
#review - tcl format can only pad with zeros or spaces?
@ -4475,6 +4496,7 @@ tcl::namespace::eval textblock {
}
set line_chunks [list]
set line_len 0
set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad
foreach {pt ansi} $parts {
if {$pt ne ""} {
set has_nl [expr {[tcl::string::last \n $pt]>=0}]
@ -4489,12 +4511,26 @@ tcl::namespace::eval textblock {
foreach pl $partlines {
lappend line_chunks $pl
#incr line_len [punk::char::ansifreestring_width $pl]
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
if {$p != $last} {
#do padding
set missing [expr {$width - $line_len}]
if {$missing > 0} {
set pad [tcl::string::repeat $padchar $missing]
#commonly in a block - many lines will have the same pad - cache based on missing
#padchar may be more than 1 wide - because of 2wide unicode and or multiple chars
if {[tcl::dict::exists $pad_cache $missing]} {
set pad [tcl::dict::get $pad_cache $missing]
} else {
set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width
if {!$pad_has_ansi} {
set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1]
} else {
set base [tcl::string::repeat " " $missing]
set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]]
}
dict set pad_cache $missing $pad
}
switch -- $which-$opt_withinansi {
r-0 {
lappend line_chunks $pad
@ -4551,7 +4587,18 @@ tcl::namespace::eval textblock {
#pad last line
set missing [expr {$width - $line_len}]
if {$missing > 0} {
set pad [tcl::string::repeat $padchar $missing]
if {[tcl::dict::exists $pad_cache $missing]} {
set pad [tcl::dict::get $pad_cache $missing]
} else {
set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width
if {!$pad_has_ansi} {
set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1]
} else {
set base [tcl::string::repeat " " $missing]
set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]]
}
}
#set pad [tcl::string::repeat $padchar $missing]
switch -- $which-$opt_withinansi {
r-0 {
lappend line_chunks $pad
@ -7156,7 +7203,7 @@ tcl::namespace::eval textblock {
#return [list $b1 $b2 $result]
return [ansistring VIEW $result]
}
tcl::namespace::import ::punk::ansi::stripansi
tcl::namespace::import ::punk::ansi::ansistrip
}

130
src/punk86.vfs/boot.tcl

@ -0,0 +1,130 @@
proc tclInit {} {
rename tclInit {}
global auto_path tcl_library tcl_libPath tcl_version tclkit_system_encoding
# find the file to mount.
set noe $::tcl::kitpath
# resolve symlinks
set noe [file dirname [file normalize [file join $noe __dummy__]]]
set tcl_library [file join $noe lib tcl$tcl_version]
set tcl_libPath [list $tcl_library [file join $noe lib]]
# get rid of a build residue
unset -nocomplain ::tclDefaultLibrary
# The following code only gets executed if we don't have our exe
# already mounted. This should only happen once per thread.
# We could use [vfs::filesystem info], but that would require
# loading vfs into every interp.
if {![file isdirectory $noe]} {
load {} vfs
# lookup and emulate "source" of lib/vfs1*/{vfs*.tcl,mk4vfs.tcl}
if {[llength [info command mk::file]]} {
set driver mk4
# must use raw Metakit calls because VFS is not yet in place
set d [mk::select exe.dirs parent 0 name lib]
set d [mk::select exe.dirs parent $d -glob name vfs1*]
foreach x {vfsUtils vfslib mk4vfs} {
set n [mk::select exe.dirs!$d.files name $x.tcl]
if {[llength $n] != 1} { error "$x: cannot find startup script"}
set s [mk::get exe.dirs!$d.files!$n contents]
catch {set s [zlib decompress $s]}
uplevel #0 $s
}
# use on-the-fly decompression, if mk4vfs understands that
# Note: 8.6 core zlib does not support this for mk4vfs
if {![package vsatisfies [package require Tcl] 8.6]} {
set mk4vfs::zstreamed 1
}
} else {
set driver mkcl
# use raw Vlerq calls if Mk4tcl is not available
# $::vlerq::starkit_root is set in the init script in kitInit.c
set rootv [vlerq get $::vlerq::starkit_root 0 dirs]
set dname [vlerq get $rootv * name]
set prows [vlerq get $rootv * parent]
foreach r [lsearch -int -all $prows 0] {
if {[lindex $dname $r] eq "lib"} break
}
# glob for a subdir in "lib", then source the specified file inside it
foreach {d f} {
vfs1* vfsUtils.tcl vfs1* vfslib.tcl vqtcl4* mkclvfs.tcl
} {
foreach z [lsearch -int -all $prows $r] {
if {[string match $d [lindex $dname $z]]} break
}
set files [vlerq get $rootv $z files]
set names [vlerq get $files * name]
set n [lsearch $names $f]
if {$n < 0} { error "$d/$f: cannot find startup script"}
set s [vlerq get $files $n contents]
catch {set s [zlib decompress $s]}
uplevel #0 $s
}
# hack the mkcl info so it will know this mount point as "exe"
set vfs::mkcl::v::rootv(exe) $rootv
set vfs::mkcl::v::dname(exe) $dname
set vfs::mkcl::v::prows(exe) $prows
}
# mount the executable, i.e. make all runtime files available
vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe]
# alter path to find encodings
if {[info tclversion] eq "8.4"} {
load {} pwb
librarypath [info library]
} else {
encoding dirs [list [file join [info library] encoding]] ;# TIP 258
}
# if the C code passed us a system encoding, apply it here.
if {[info exists tclkit_system_encoding]} {
# It is possible the chosen encoding is unavailable in which case
# we will be left with 'identity' to be handled below.
catch {encoding system $tclkit_system_encoding}
unset tclkit_system_encoding
}
# fix system encoding, if it wasn't properly set up (200207.004 bug)
if {[encoding system] eq "identity"} {
switch $::tcl_platform(platform) {
windows { encoding system cp1252 }
macintosh { encoding system macRoman }
default { encoding system iso8859-1 }
}
}
# now remount the executable with the correct encoding
vfs::filesystem unmount $noe
set noe $::tcl::kitpath
# resolve symlinks
set noe [file dirname [file normalize [file join $noe __dummy__]]]
set tcl_library [file join $noe lib tcl$tcl_version]
set tcl_libPath [list $tcl_library [file join $noe lib]]
vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe]
}
# load config settings file if present
namespace eval ::vfs { variable tclkit_version 1 }
catch { uplevel #0 [list source [file join $noe config.tcl]] }
uplevel #0 [list source [file join $tcl_library init.tcl]]
# reset auto_path, so that init.tcl's search outside of tclkit is cancelled
set auto_path $tcl_libPath
# Ditto for Tcl module search path
tcl::tm::path remove {*}[tcl::tm::path list]
tcl::tm::roots [list [file join $noe lib]]
}

1
src/punk86.vfs/config.tcl

@ -0,0 +1 @@
set ::vfs::tclkit_version 200611.001

20
src/punk86.vfs/lib/app-punk/repl.tcl

@ -14,6 +14,8 @@ package provide app-punk 1.0
set original_tm_list [tcl::tm::list]
tcl::tm::remove {*}$original_tm_list
set module_folders [list]
#tm list first added end up later in the list - and then override earlier ones if version the same - so add pwd-relative 1st to give higher priority
#(only if Tcl has scanned all paths - see below bogus package load)
#1
@ -21,6 +23,8 @@ if {[file isdirectory [pwd]/modules]} {
catch {tcl::tm::add [pwd]/modules}
}
set tclmajorv [lindex [split [info tclversion] .] 0]
#2)
if {[string match "*.vfs/*" [file normalize [info script]]]} {
#src/xxx.vfs/lib/app-punk/repl.tcl
@ -28,18 +32,24 @@ if {[string match "*.vfs/*" [file normalize [info script]]]} {
#set srcmodulefolder [file dirname [file dirname [file dirname [file dirname [file normalize [info script]]]]]]/modules
# - the src/modules folder doesn't contain important modules such as vendormodules - so the above probably isn't that useful
set srcfolder [file dirname [file dirname [file dirname [file dirname [file normalize [info script]]]]]]
set modulefolder [file join [file dirname $srcfolder] modules] ;#modules folder at same level as src folder
lappend module_folders [file join [file dirname $srcfolder] modules] ;#modules folder at same level as src folder
lappend module_folders [file join [file dirname $srcfolder] modules_tcl$tclmajorv]
} else {
# .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder)
set modulefolder [file dirname [file dirname [info nameofexecutable]]]/modules
lappend module_folders [file dirname [file dirname [info nameofexecutable]]]/modules
lappend module_folders [file dirname [file dirname [info nameofexecutable]]]/modules_tcl$tclmajorv
}
if {[file isdirectory $modulefolder]} {
foreach modulefolder $module_folders {
if {[file isdirectory $modulefolder]} {
tcl::tm::add $modulefolder
} else {
} else {
puts stderr "Warning unable to find module folder at: $modulefolder"
}
}
#TODO! lib_tcl8 lib_tcl9 etc based on tclmajorv
#libs are appended to end - so add higher prioriy libraries last (opposite to modules)
#auto_path - add exe-relative after exe-relative path
if {"windows" eq $::tcl_platform(platform)} {

36
src/punk86.vfs/lib/gridplus2.11/LICENSE.GRIDPLUS

@ -1,36 +0,0 @@
This software (GRIDPLUS) is Copyright (c) 2004-2015 by Adrian Davis (adrian@satisoft.com).
The author hereby grants permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that
this notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors
and need not follow the licensing terms described here, provided that
the new terms are clearly indicated on the first page of each file
where they apply.
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY
OF SUCH DAMAGE.
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS,
OR MODIFICATIONS.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense,
the software shall be classified as "Commercial Computer Software"
and the Government shall have only "Restricted Rights" as defined in
Clause 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing,
the authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.

6871
src/punk86.vfs/lib/gridplus2.11/gridplus.tcl

File diff suppressed because it is too large Load Diff

1
src/punk86.vfs/lib/gridplus2.11/pkgIndex.tcl

@ -1 +0,0 @@
package ifneeded gridplus 2.11 [list source [file join $dir gridplus.tcl]]

3
src/runtime/mapvfs.config

@ -4,7 +4,8 @@
#e.g
#- myproject.vfs
#- punk86.vfs
tclkit86bi.exe punk86.vfs
#tclkit86bi.exe punk86.vfs
tclkit8613.exe punk86.vfs
#tclkit87a5bawt.exe punk86.vfs
#tclkit86bi.exe vfs_windows/punk86win.vfs

BIN
src/vendormodules/Thread-2.8.9.tm

Binary file not shown.

BIN
src/vendormodules/Thread/platform/win32_x86_64-2.8.9.tm

Binary file not shown.

143
src/vendormodules/dictutils-0.2.tm

@ -1,143 +0,0 @@
# dictutils.tcl --
#
# Various dictionary utilities.
#
# Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk).
#
# License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style).
#
package require Tcl 8.6-
package provide dictutils 0.2
namespace eval dictutils {
namespace export equal apply capture witharray nlappend
namespace ensemble create
# dictutils witharray dictVar arrayVar script --
#
# Unpacks the elements of the dictionary in dictVar into the array
# variable arrayVar and then evaluates the script. If the script
# completes with an ok, return or continue status, then the result is copied
# back into the dictionary variable, otherwise it is discarded. A
# [break] can be used to explicitly abort the transaction.
#
proc witharray {dictVar arrayVar script} {
upvar 1 $dictVar dict $arrayVar array
array set array $dict
try { uplevel 1 $script
} on break {} { # Discard the result
} on continue result - on ok result {
set dict [array get array] ;# commit changes
return $result
} on return {result opts} {
set dict [array get array] ;# commit changes
dict incr opts -level ;# remove this proc from level
return -options $opts $result
}
# All other cases will discard the changes and propagage
}
# dictutils equal equalp d1 d2 --
#
# Compare two dictionaries for equality. Two dictionaries are equal
# if they (a) have the same keys, (b) the corresponding values for
# each key in the two dictionaries are equal when compared using the
# equality predicate, equalp (passed as an argument). The equality
# predicate is invoked with the key and the two values from each
# dictionary as arguments.
#
proc equal {equalp d1 d2} {
if {[dict size $d1] != [dict size $d2]} { return 0 }
dict for {k v} $d1 {
if {![dict exists $d2 $k]} { return 0 }
if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 }
}
return 1
}
# apply dictVar lambdaExpr ?arg1 arg2 ...? --
#
# A combination of *dict with* and *apply*, this procedure creates a
# new procedure scope populated with the values in the dictionary
# variable. It then applies the lambdaTerm (anonymous procedure) in
# this new scope. If the procedure completes normally, then any
# changes made to variables in the dictionary are reflected back to
# the dictionary variable, otherwise they are ignored. This provides
# a transaction-style semantics whereby atomic updates to a
# dictionary can be performed. This procedure can also be useful for
# implementing a variety of control constructs, such as mutable
# closures.
#
proc apply {dictVar lambdaExpr args} {
upvar 1 $dictVar dict
set env $dict ;# copy
lassign $lambdaExpr params body ns
if {$ns eq ""} { set ns "::" }
set body [format {
upvar 1 env __env__
dict with __env__ %s
} [list $body]]
set lambdaExpr [list $params $body $ns]
set rc [catch { ::apply $lambdaExpr {*}$args } ret opts]
if {$rc == 0} {
# Copy back any updates
set dict $env
}
return -options $opts $ret
}
# capture ?level? ?exclude? ?include? --
#
# Captures a snapshot of the current (scalar) variable bindings at
# $level on the stack into a dictionary environment. This dictionary
# can later be used with *dictutils apply* to partially restore the
# scope, creating a first approximation of closures. The *level*
# argument should be of the forms accepted by *uplevel* and
# designates which level to capture. It defaults to 1 as in uplevel.
# The *exclude* argument specifies an optional list of literal
# variable names to avoid when performing the capture. No variables
# matching any item in this list will be captured. The *include*
# argument can be used to specify a list of glob patterns of
# variables to capture. Only variables matching one of these
# patterns are captured. The default is a single pattern "*", for
# capturing all visible variables (as determined by *info vars*).
#
proc capture {{level 1} {exclude {}} {include {*}}} {
if {[string is integer $level]} { incr level }
set env [dict create]
foreach pattern $include {
foreach name [uplevel $level [list info vars $pattern]] {
if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue }
upvar $level $name value
catch { dict set env $name $value } ;# no arrays
}
}
return $env
}
# nlappend dictVar keyList ?value ...?
#
# Append zero or more elements to the list value stored in the given
# dictionary at the path of keys specified in $keyList. If $keyList
# specifies a non-existent path of keys, nlappend will behave as if
# the path mapped to an empty list.
#
proc nlappend {dictvar keylist args} {
upvar 1 $dictvar dict
if {[info exists dict] && [dict exists $dict {*}$keylist]} {
set list [dict get $dict {*}$keylist]
}
lappend list {*}$args
dict set dict {*}$keylist $list
}
# invoke cmd args... --
#
# Helper procedure to invoke a callback command with arguments at
# the global scope. The helper ensures that proper quotation is
# used. The command is expected to be a list, e.g. {string equal}.
#
proc invoke {cmd args} { uplevel #0 $cmd $args }
}

BIN
src/vendormodules/gridplus-2.11.tm

Binary file not shown.

17
src/vendormodules/include_modules.config

@ -0,0 +1,17 @@
set local_modules [list\
c:/repo/jn/tclmodules/overtype/modules overtype\
c:/repo/jn/tclmodules/modpod/modules modpod\
c:/repo/jn/tclmodules/packageTest/modules packageTest\
c:/repo/jn/tclmodules/gridplus/modules gridplus\
c:/repo/jn/tclmodules/tablelist/modules tablelist\
c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\
c:/repo/jn/tclmodules/Thread/modules Thread\
c:/repo/jn/tclmodules/Thread/modules Thread::platform::win32_x86_64\
]
set fossil_modules [dict create\
]
set git_modules [dict create\
]

2
src/vendormodules/md5-2.0.8.tm

@ -16,7 +16,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
package require Tcl 8.2; # tcl minimum version
package require Tcl 8.2-; # tcl minimum version
namespace eval ::md5 {
variable accel

700
src/vendormodules/modpod-0.1.0.tm

@ -0,0 +1,700 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application modpod 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin modpod_module_modpod 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 modpod]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of modpod
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by modpod
#[list_begin itemized]
package require Tcl 8.6-
package require struct::set ;#review
package require punk::lib
package require punk::args
#*** !doctools
#[item] [package {Tcl 8.6-}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval modpod::class {
#*** !doctools
#[subsection {Namespace modpod::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
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval modpod {
namespace export {[a-z]*}; # Convention: export all lowercase
variable connected
if {![info exists connected(to)]} {
set connected(to) list
}
variable modpodscript
set modpodscript [info script]
if {[string tolower [file extension $modpodscript]] eq ".tcl"} {
set connected(self) [file dirname $modpodscript]
} else {
#expecting a .tm
set connected(self) $modpodscript
}
variable loadables [info sharedlibextension]
variable sourceables {.tcl .tk} ;# .tm ?
#*** !doctools
#[subsection {Namespace modpod}]
#[para] Core API functions for modpod
#[list_begin definitions]
#proc sample1 {p1 args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [opt {?option value...?}]]
# #[para]Description of sample1
# return "ok"
#}
proc connect {args} {
puts stderr "modpod::connect--->>$args"
set argd [punk::args::get_dict {
-type -default ""
*values -min 1 -max 1
path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
} $args]
catch {
punk::lib::showdict $argd ;#heavy dependencies
}
set opt_path [dict get $argd values path]
variable connected
set original_connectpath $opt_path
set modpodpath [modpod::system::normalize $opt_path] ;#
if {$modpodpath in $connected(to)} {
return [dict create ok ALREADY_CONNECTED]
}
lappend connected(to) $modpodpath
set connected(connectpath,$opt_path) $original_connectpath
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info_script]]}]
set connected(location,$modpodpath) [file dirname $modpodpath]
set connected(startdata,$modpodpath) -1
set connected(type,$modpodpath) [dict get $argd-opts -type]
set connected(fh,$modpodpath) ""
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} {
set connected(type,$modpodpath) "unwrapped"
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath)
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]]
} else {
#connect to .tm but may still be unwrapped version available
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath)
set this_pkg_tm_folder [file dirname $modpodpath]
if {$connected(type,$modpodpath) ne "unwrapped"} {
#Not directly connected to unwrapped version - but may still be redirected there
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)]
if {[file exists $unwrappedFolder]} {
#folder with exact version-match must exist for redirect to 'unwrapped'
set con(type,$modpodpath) "modpod-redirecting"
}
}
}
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm"
set connected(tmfile,$modpodpath)
set tail_segments [list]
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]]
set lcase_modulepaths [string tolower [tcl::tm::list]]
foreach lc_mpath $lcase_modulepaths {
set mpath_segments [file split $lc_mpath]
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} {
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end]
break
}
}
if {[llength $tail_segments]} {
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require
} else {
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)]
}
switch -exact -- $connected(type,$modpodpath) {
"modpod-redirecting" {
#redirect to the unwrapped version
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl]
}
"unwrapped" {
if {[info commands ::thread::id] ne ""} {
set from [pid],[thread::id]
} else {
set from [pid]
}
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath"
return [list ok ""]
}
default {
#autodetect .tm - zip/tar ?
#todo - use vfs ?
#connect to tarball - start at 1st header
set connected(startdata,$modpodpath) 0
set fh [open $modpodpath r]
set connected(fh,$modpodpath) $fh
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {}
if {$connected(startdata,$modpodpath) >= 0} {
#verify we have a valid tar header
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} {
seek $fh $connected(startdata,$modpodpath) start
return [list ok $fh]
} else {
#error "cannot verify tar header"
}
}
lpop connected(to) end
set connected(startdata,$modpodpath) -1
unset connected(fh,$modpodpath)
catch {close $fh}
return [dict create err {Does not appear to be a valid modpod}]
}
}
}
proc disconnect {{modpod ""}} {
variable connected
if {![llength $connected(to)]} {
return 0
}
if {$modpod eq ""} {
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]"
set modpod [lindex $connected(to) end]
}
if {[set posn [lsearch $connected(to) $modpod]] == -1} {
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod"
return 0
}
if {[string length $connected(fh,$modpod)]} {
close $connected(fh,$modpod)
}
array unset connected *,$modpod
set connected(to) [lreplace $connected(to) $posn $posn]
return 1
}
proc get {args} {
set argd [punk::args::get_dict {
-from -default "" -help "path to pod"
*values -min 1 -max 1
filename
} $args]
set frompod [dict get $argd opts -from]
set filename [dict get $argd values filename]
variable connected
set modpod [::tarjar::system::connect_if_not $frompod]
set fh $connected(fh,$modpod)
if {$connected(type,$modpod) eq "unwrapped"} {
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder
if {[string range $filename 0 0 eq "/"]} {
#absolute path (?)
set path [file join $connected(location,$modpod) .. [string trim $filename /]]
} else {
#relative path - use #modpod-xxx as base
set path [file join $connected(location,$modpod) $filename]
}
set fd [open $path r]
#utf-8?
#fconfigure $fd -encoding iso8859-1 -translation binary
return [list ok [lindex [list [read $fd] [close $fd]] 0]]
} else {
#read from vfs
puts stderr "get $filename from wrapped pod '$frompod' not implemented"
}
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace modpod ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval modpod::lib {
namespace export {[a-z]*}; # Convention: export all lowercase
namespace path [namespace parent]
#*** !doctools
#[subsection {Namespace modpod::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
proc is_valid_tm_version {versionpart} {
#Needs to be suitable for use with Tcl's 'package vcompare'
if {![catch [list package vcompare $versionparts $versionparts]]} {
return 1
} else {
return 0
}
}
proc make_zip_modpod {zipfile outfile} {
set mount_stub {
#zip file with Tcl loader prepended.
#generated using modpod::make_zip_modpod
if {[catch {file normalize [info script]} modfile]} {
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)"
}
if {$modfile eq "" || ![file exists $modfile]} {
error "modpod zip stub error. Unable to determine module path"
}
set moddir [file dirname $modfile]
set mod_and_ver [file rootname [file tail $modfile]]
lassign [split $mod_and_ver -] moduletail version
if {[file exists $moddir/#modpod-$mod_and_ver]} {
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm
} else {
#determine module namespace so we can mount appropriately
proc intersect {A B} {
if {[llength $A] == 0} {return {}}
if {[llength $B] == 0} {return {}}
if {[llength $B] > [llength $A]} {
set res $A
set A $B
set B $res
}
set res {}
foreach x $A {set ($x) {}}
foreach x $B {
if {[info exists ($x)]} {
lappend res $x
}
}
return $res
}
set lcase_tmfile_segments [string tolower [file split $moddir]]
set lcase_modulepaths [string tolower [tcl::tm::list]]
foreach lc_mpath $lcase_modulepaths {
set mpath_segments [file split $lc_mpath]
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} {
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use propertly cased tail
break
}
}
if {[llength $tail_segments]} {
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver
} else {
set fullpackage $moduletail
set mount_at #modpod/#mounted-modpod-$mod_and_ver
}
if {[info commands tcl::zipfs::mount] ne ""} {
#argument order changed to be consistent with vfs::zip::Mount etc
#early versions: zipfs::Mount mountpoint zipname
#since 2023-09: zipfs::Mount zipname mountpoint
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on non-existance)
set mountpoints [dict keys [tcl::zipfs::mount]]
if {"//zipfs:/$mount_at" ni $mountpoints} {
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it
if {[catch {
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?)
puts "tcl::zipfs::mount $modfile $mount_at"
tcl::zipfs::mount $modfile $mount_at
} errM]} {
#try old api
puts stderr ">>> tcl::zipfs::mount //zipfs://$mount_at $modfile"
tcl::zipfs::mount //zipfs:/$mount_at $modfile
}
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} {
puts stderr "zipfs mounts: [zipfs mount]"
#tcl::zipfs::unmount //zipfs:/$mount_at
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage"
}
}
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm
} else {
#fallback to slower vfs::zip
#NB. We don't create the intermediate dirs - but the mount still works
if {![file exists $moddir/$mount_at]} {
if {[catch {package require vfs::zip} errM]} {
set msg "Unable to load vfs::zip package to mount module $mod_and_ver"
append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place."
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $
}
set fd [vfs::zip::Mount $modfile $moddir/$mount_at]
if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} {
vfs::zip::Unmount $fd $moddir/$mount_at
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage"
}
}
source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm
}
}
#zipped data follows
}
#todo - test if zipfile has #modpod-loadcript.tcl before even creating
append mount_stub \x1A
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub
}
proc make_zip_modpod1 {zipfile outfile} {
set mount_stub {
#zip file with Tcl loader prepended.
#generated using modpod::make_zip_modpod
if {[catch {file normalize [info script]} modfile]} {
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)"
}
if {$modfile eq "" || ![file exists $modfile]} {
error "modpod zip stub error. Unable to determine module path"
}
set moddir [file dirname $modfile]
set mod_and_ver [file rootname [file tail $modfile]]
lassign [split $mod_and_ver -] moduletail version
if {[file exists $moddir/#modpod-$mod_and_ver]} {
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm
} else {
if {![file exists $moddir/#mounted-modpod-$mod_and_ver]} {
if {[catch {package require vfs::zip} errM]} {
set msg "Unable to load vfs::zip package to mount module $mod_and_ver"
append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place."
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $
}
set fd [vfs::zip::Mount $modfile $moddir/#mounted-modpod-$mod_and_ver]
if {![file exists $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm]} {
vfs::zip::Unmount $fd $moddir/#mounted-modpod-$mod_and_ver
error "Unable to find #modpod-$mod_and_ver/$mod_and_ver.tm in $modfile"
}
}
source $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm
}
#zipped data follows
}
#todo - test if zipfile has #modpod-loadcript.tcl before even creating
append mount_stub \x1A
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub
}
proc make_zip_source_mountable {zipfile outfile} {
set mount_stub {
package require vfs::zip
vfs::zip::Mount [info script] [info script]
}
append mount_stub \x1A
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace modpod::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
namespace eval modpod::system {
#*** !doctools
#[subsection {Namespace modpod::system}]
#[para] Internal functions that are not part of the API
#deflate,store only supported
proc make_mountable_zip {zipfile outfile mount_stub} {
set in [open $zipfile r]
fconfigure $in -encoding iso8859-1 -translation binary
set out [open $outfile w+]
fconfigure $out -encoding iso8859-1 -translation binary
puts -nonewline $out $mount_stub
set offset [tell $out]
lappend report "sfx stub size: $offset"
fcopy $in $out
close $in
set size [tell $out]
#Now seek in $out to find the end of directory signature:
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text
if {$size < 65559} {
set seek 0
} else {
set seek [expr {$size - 65559}]
}
seek $out $seek
set data [read $out]
set start_of_end [string last "\x50\x4b\x05\x06" $data]
#set start_of_end [expr {$start_of_end + $seek}]
incr start_of_end $seek
lappend report "START-OF-END: $start_of_end ([expr {$start_of_end - $size}]) [string length $data]"
seek $out $start_of_end
set end_of_ctrl_dir [read $out]
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len)
lappend report "End of central directory: [array get eocd]"
seek $out [expr {$start_of_end+16}]
#adjust offset of start of central directory by the length of our sfx stub
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $offset}]]
flush $out
seek $out $start_of_end
set end_of_ctrl_dir [read $out]
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len)
# 0x06054b50 - end of central dir signature
puts stderr "$end_of_ctrl_dir"
puts stderr "comment_len: $eocd(comment_len)"
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]"
lappend report "New dir offset: $eocd(diroffset)"
lappend report "Adjusting $eocd(totalnum) zip file items."
catch {
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies
}
seek $out $eocd(diroffset)
for {set i 0} {$i <$eocd(totalnum)} {incr i} {
set current_file [tell $out]
set fileheader [read $out 46]
puts --------------
puts [ansistring VIEW -lf 1 $fileheader]
puts --------------
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset)
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset)
set ::last_header $fileheader
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])"
puts "ver: $x(version)"
puts "method: $x(method)"
#33639248 dec = 0x02014b50 - central file header signature
if { $x(sig) != 33639248 } {
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]"
}
foreach size $x(lengths) var {filename extrafield comment} {
if { $size > 0 } {
set x($var) [read $out $size]
} else {
set x($var) ""
}
}
set next_file [tell $out]
lappend report "file $i: $x(offset) $x(sizes) $x(filename)"
seek $out [expr {$current_file+42}]
puts -nonewline $out [binary format i [expr {$x(offset)+$offset}]]
#verify:
flush $out
seek $out $current_file
set fileheader [read $out 46]
lappend report "old $x(offset) + $offset"
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset)
lappend report "new $x(offset)"
seek $out $next_file
}
close $out
#pdict/showdict reuire punk & textlib - ie lots of dependencies
#don't fall over just because of that
catch {
punk::lib::showdict -roottype list -chan stderr $report
}
#puts [join $report \n]
return
}
proc connect_if_not {{podpath ""}} {
upvar ::modpod::connected connected
set podpath [::modpod::system::normalize $podpath]
set docon 0
if {![llength $connected(to)]} {
if {![string length $podpath]} {
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified"
} else {
set docon 1
}
} else {
if {![string length $podpath]} {
set podpath [lindex $connected(to) end]
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]"
} else {
if {$podpath ni $connected(to)} {
set docon 1
}
}
}
if {$docon} {
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} {
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod"
} else {
return $podpath
}
}
#we were already connected
return $podpath
}
proc myversion {} {
upvar ::modpod::connected connected
set script [info script]
if {![string length $script]} {
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod"
}
set fname [file tail [file rootname [file normalize $script]]]
set scriptdir [file dirname $script]
if {![string match "#modpod-*" $fname]} {
lassign [lrange [split $fname -] end-1 end] _pkgname version
} else {
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version
if {![string length $version]} {
#try again on the name of the containing folder
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version
#todo - proper walk up the directory tree
if {![string length $version]} {
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod)
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version
}
}
}
#tarjar::Log debug "'myversion' determined version for [info script]: $version"
return $version
}
proc myname {} {
upvar ::modpod::connected connected
set script [info script]
if {![string length $script]} {
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod"
}
return $connected(fullpackage,$script)
}
proc myfullname {} {
upvar ::modpod::connected connected
set script [info script]
#set script [::tarjar::normalize $script]
set script [file normalize $script]
if {![string length $script]} {
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar"
}
return $::tarjar::connected(fullpackage,$script)
}
proc normalize {path} {
#newer versions of Tcl don't do tilde sub
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths)
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function.
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes..
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after
set path [file normalize $path]
#set path [string tolower $path] ;#must do this after file normalize
return [string map [list $matilda ~] $path] ;#get our tildes back.
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide modpod [namespace eval modpod {
variable pkg modpod
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

705
src/bootsupport/modules/overtype-1.6.3.tm → src/vendormodules/overtype-1.6.5.tm

File diff suppressed because it is too large Load Diff

BIN
src/vendormodules/packageTest-0.1.0.tm

Binary file not shown.

BIN
src/vendormodules/tablelist-6.22.tm

Binary file not shown.

1
src/vendormodules/tablelist_tile-6.22.tm

@ -0,0 +1 @@
source [file dirname [info script]]/tablelist-6.22.tm

2
src/vendormodules/textutil/wcswidth-35.2.tm

@ -8,7 +8,7 @@
# Author: Sean Woods <yoda@etoyoc.com>
# Author: Andreas Kupries <andreas.kupries@gmail.com>
###
package require Tcl 8.5
package require Tcl 8.5-
package provide textutil::wcswidth 35.2
namespace eval ::textutil {}

11
src/vendormodules_tcl8/include_modules.config

@ -0,0 +1,11 @@
set local_modules [list\
c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread\
c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread::platform::win32_x86_64_tcl8\
]
set fossil_modules [dict create\
]
set git_modules [dict create\
]

BIN
src/vendormodules_tcl9/Thread-3.0b3.tm

Binary file not shown.

BIN
src/vendormodules_tcl9/Thread/platform/win32_x86_64_tcl9-3.0b3.tm

Binary file not shown.

11
src/vendormodules_tcl9/include_modules.config

@ -0,0 +1,11 @@
set local_modules [list\
c:/repo/jn/tclmodules/Thread/modules_tcl9 Thread\
c:/repo/jn/tclmodules/Thread/modules_tcl9 Thread::platform::win32_x86_64_tcl9\
]
set fossil_modules [dict create\
]
set git_modules [dict create\
]
Loading…
Cancel
Save