jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

misc fixes, punk::args, repl timing, tclcore & tkcore docs, libunknown, test::punk::ansi testsuite beginning

master
Julian Noble 2 days ago
parent
0b10aa8cab
commit
4773a6a562
63 changed files with 30434 additions and 3073 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 2
      src/lib/app-punk/repl.tcl
  2. 37
      src/modules/argparsingtest-999999.0a1.0.tm
  3. 179
      src/modules/punk-0.1.tm
  4. 2
      src/modules/punk/aliascore-999999.0a1.0.tm
  5. 977
      src/modules/punk/ansi-999999.0a1.0.tm
  6. 969
      src/modules/punk/ansi/colourmap-999999.0a1.0.tm
  7. 3
      src/modules/punk/ansi/colourmap-buildversion.txt
  8. 4829
      src/modules/punk/args-999999.0a1.0.tm
  9. 842
      src/modules/punk/args/tclcore-999999.0a1.0.tm
  10. 622
      src/modules/punk/args/tkcore-999999.0a1.0.tm
  11. 3
      src/modules/punk/args/tkcore-buildversion.txt
  12. 15
      src/modules/punk/console-999999.0a1.0.tm
  13. 1
      src/modules/punk/du-999999.0a1.0.tm
  14. 134
      src/modules/punk/lib-999999.0a1.0.tm
  15. 687
      src/modules/punk/libunknown-0.1.tm
  16. 9
      src/modules/punk/mix/commandset/module-999999.0a1.0.tm
  17. 3
      src/modules/punk/nav/fs-999999.0a1.0.tm
  18. 49
      src/modules/punk/ns-999999.0a1.0.tm
  19. 60
      src/modules/punk/packagepreference-999999.0a1.0.tm
  20. 6
      src/modules/punk/path-999999.0a1.0.tm
  21. 167
      src/modules/punk/repl-999999.0a1.0.tm
  22. 2
      src/modules/punk/repl-buildversion.txt
  23. 2
      src/modules/punk/repl/codethread-999999.0a1.0.tm
  24. 183
      src/modules/shellfilter-0.2.tm
  25. 80
      src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-0.1.1_testsuites/ansi/ansistrip.test
  26. 0
      src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-0.1.1_testsuites/tests/ansistrip.test#..+ansi+ansistrip.test.fauxlink
  27. 225
      src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-999999.0a1.0.tm
  28. 77
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test
  29. 3
      src/modules/test/punk/ansi-buildversion.txt
  30. 3
      src/modules/textblock-999999.0a1.0.tm
  31. 152
      src/vfs/_config/punk_main.tcl
  32. 2
      src/vfs/_vfscommon.vfs/lib/app-punk/repl.tcl
  33. 37
      src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm
  34. 202
      src/vfs/_vfscommon.vfs/modules/punk-0.1.tm
  35. 2
      src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm
  36. 977
      src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm
  37. 969
      src/vfs/_vfscommon.vfs/modules/punk/ansi/colourmap-0.1.0.tm
  38. 683
      src/vfs/_vfscommon.vfs/modules/punk/args-0.1.9.tm
  39. 9550
      src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm
  40. 2330
      src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm
  41. 622
      src/vfs/_vfscommon.vfs/modules/punk/args/tkcore-0.1.0.tm
  42. 21
      src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm
  43. 1
      src/vfs/_vfscommon.vfs/modules/punk/du-0.1.0.tm
  44. 135
      src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.2.tm
  45. 687
      src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm
  46. 9
      src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm
  47. 3
      src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm
  48. 142
      src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm
  49. 60
      src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm
  50. 6
      src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm
  51. 10
      src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm
  52. 3661
      src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm
  53. 2
      src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm
  54. 11
      src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm
  55. 3322
      src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.tm
  56. 107
      src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm
  57. BIN
      src/vfs/_vfscommon.vfs/modules/test/punk/ansi-0.1.1.tm
  58. BIN
      src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm
  59. 47
      src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm

2
src/lib/app-punk/repl.tcl
Unescape View File

@ -34,6 +34,8 @@ set thread_version [package require Thread]
package require shellfilter
package require punk::repl
#set v [package provide punk::repl]
#puts stderr "punk::repl version:$v script: [package ifneeded punk::repl $v]"
#puts stderr "package names"
#set packages_present [list]
#foreach p [package names] {

37
src/modules/argparsingtest-999999.0a1.0.tm
Unescape View File

@ -321,6 +321,7 @@ namespace eval argparsingtest {
punk::args::define {
@id -id ::argparsingtest::test1_punkargs2
@cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@leaders -min 0 -max 0
@opts -anyopts 0
-return -default string -type string
-frametype -default \uFFEF -type string
@ -333,10 +334,10 @@ namespace eval argparsingtest {
-1 -default 1 -type boolean
-2 -default 2 -type integer
-3 -default 3 -type integer
@values
@values -min 0 -max 0
}
proc test1_punkargs2 {args} {
set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args]
set argd [punk::args::parse $args withid ::argparsingtest::test1_punkargs2]
return [tcl::dict::get $argd opts]
}
@ -494,6 +495,38 @@ namespace eval argparsingtest {
}]]
return $argd
}
proc test_multiline2 {args} {
set t3 [textblock::frame t3]
set argd [punk::args::parse $args withdef {
-template1 -default {
******
* t1 *
******
}
-template2 -default { ------
******
* t2 *
******}
-template3 -default {$t3}
#substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately
-template3b -default {
${$t3}
-----------------
${$t3}
abc\ndef
}
-template4 -default "******
* t4 *
******"
-template5 -default "
a
${$t3}
c
"
-flag -default 0 -type boolean
}]
return $argd
}
#proc sample1 {p1 n args} {
# #*** !doctools

179
src/modules/punk-0.1.tm
Unescape View File

@ -515,6 +515,7 @@ namespace eval punk {
#proc ::objclone {obj} {
# append obj2 $obj {}
#}
#-----------------------------------------------------------------------------------
#order of arguments designed for pipelining
#review - 'piper_' prefix is a naming convention for functions that are ordered for tail-argument pipelining
@ -530,6 +531,152 @@ namespace eval punk {
proc ::punk::K {x y} { return $x}
#todo ansigrep? e.g grep using ansistripped value
proc grepstr1 {pattern data} {
set data [string map {\r\n \n} $data]
set lines [split $data \n]
set matches [lsearch -all -regexp $lines $pattern]
set max [lindex $matches end]
set w1 [string length $max]
set result ""
set H [a+ green bold overline]
set R \x1b\[m
foreach m $matches {
set ln [lindex $lines $m]
set ln [regsub -all $pattern $ln $H&$R]
append result [format %${w1}s $m] " $ln" \n
}
set result [string trimright $result \n]
return $result
}
#----------------------
#todo - fix overtype
#create test
#overtype::renderline -insert_mode 0 -transparent 1 [a+ green]-----[a] " [a+ underline]x[a]"
#----------------------
punk::args::define {
@id -id ::punk::grepstr
@cmd -name punk::grepstr\
-summary\
"Grep for regex pattern in supplied (possibly ANSI) string."\
-help\
""
@leaders -min 0 -max 0
@opts
-returnlines -type string -default all -choices {matched all}
-ansistrip -type none
-no-linenumbers -type none
-highlight -type list -typesynopsis ansinames -default {green bold Black underline overline} -help\
"list of ANSI SGR style codes as supported by and documented in punk::ansi::a?"
-- -type none
@values
pattern -type string -help\
"regex pattern to match in plaintext portion of ANSI string"
string -type string
}
proc grepstr {args} {
lassign [dict values [punk::args::parse $args withid ::punk::grepstr]] leaders opts values received
set pattern [dict get $values pattern]
set data [dict get $values string]
set do_strip 0
if {[dict exists $received -ansistrip]} {
set data [punk::ansi::ansistrip $data]
}
set highlight [dict get $opts -highlight]
set returnlines [dict get $opts -returnlines]
if {[dict exists $received -no-linenumbers]} {
set do_linenums 0
} else {
set do_linenums 1
}
if {[llength $highlight] == 0} {
set H ""
set R ""
} else {
set H [a+ {*}$highlight]
set R \x1b\[m
}
set data [string map {\r\n \n} $data]
if {![punk::ansi::ta::detect $data]} {
set lines [split $data \n]
set matches [lsearch -all -regexp $lines $pattern]
set result ""
if {$returnlines eq "all"} {
set returnlines [punk::lib::range 0 [llength $lines]-1]
} else {
set returnlines $matches
}
set max [lindex $returnlines end]
set w1 [string length $max]
foreach linenum $returnlines {
if {$do_linenums} {
set col1 "[format %${w1}s $linenum] "
} else {
set col1 ""
}
set ln [lindex $lines $linenum]
if {$linenum in $matches} {
set ln [regsub -all -- $pattern $ln $H&$R]
}
append result $col1 $ln \n
}
set result [string trimright $result \n]
return $result
} else {
set plain [punk::ansi::ansistrip $data]
set plainlines [split $plain \n]
set lines [split $data \n]
set matches [lsearch -all -regexp $plainlines $pattern]
if {$returnlines eq "all"} {
set returnlines [punk::lib::range 0 [llength $lines]-1]
} else {
set returnlines $matches
}
set max [lindex $returnlines end]
set w1 [string length $max]
set result ""
set placeholder \UFFEF ;#review
foreach linenum $returnlines {
set ln [lindex $lines $linenum]
if {$do_linenums} {
set col1 "[format %${w1}s $linenum] "
} else {
set col1 ""
}
if {$linenum in $matches} {
set plain_ln [lindex $plainlines $linenum]
set parts [regexp -all -indices -inline -- $pattern $plain_ln]
if {[llength $parts] == 0} {
#shouldn't happen
append result $col1 $ln \n
} else {
set overlay ""
set i 0
foreach prange $parts {
lassign $prange s e
set prelen [expr {$s - $i}]
append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]$R
set i [expr {$e + 1}]
}
set tail [string range $plain_ln $e+1 end]
append overlay [string repeat $placeholder [string length $tail]]
#puts "$overlay"
#puts "$ln"
append result $col1 [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay] \n
}
} else {
append result $col1 $ln \n
}
}
return $result
}
}
proc stacktrace {} {
set stack "Stack trace:\n"
for {set i 1} {$i < [info level]} {incr i} {
@ -7510,27 +7657,33 @@ namespace eval punk {
set indent [string repeat " " [string length "WARNING: "]]
lappend cstring_tests [dict create\
type "PM "\
msg "PRIVACY MESSAGE"\
msg "UN"\
f7 punk::ansi::controlstring_PM\
f7desc "7bit ESC ^"\
f7prefix "7bit ESC ^ secret "\
f7suffix "safe"\
f8 punk::ansi::controlstring_PM8\
f8desc "8bit \\x9e"\
f8prefix "8bit \\x9e secret "\
f8suffix "safe"\
]
lappend cstring_tests [dict create\
type SOS\
msg "STRING"\
msg "NOT"\
f7 punk::ansi::controlstring_SOS\
f7desc "7bit ESC X"\
f7prefix "7bit ESC X string "\
f7suffix " hidden"\
f8 punk::ansi::controlstring_SOS8\
f8desc "8bit \\x98"\
f8prefix "8bit \\x98 string "\
f8suffix " hidden"\
]
lappend cstring_tests [dict create\
type APC\
msg "APPLICATION PROGRAM COMMAND"\
msg "NOT"\
f7 punk::ansi::controlstring_APC\
f7desc "7bit ESC _"\
f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\
f7suffix " hidden"\
f8 punk::ansi::controlstring_APC8\
f8desc "8bit \\x9f"\
f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\
f8suffix " hidden"\
]
foreach test $cstring_tests {
@ -7540,14 +7693,14 @@ namespace eval punk {
set hidden_width_m8 [punk::console::test_char_width $m8]
if {$hidden_width_m != 0 || $hidden_width_m8 != 0} {
if {$hidden_width_m == 0} {
set d "[a+ green bold][dict get $test f7desc] [a red]${m}[a]"
set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]"
} else {
set d "[a+ yellow bold][dict get $test f7desc] [a red]$m[a]"
set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]"
}
if {$hidden_width_m8 == 0} {
set d8 "[a+ green ][dict get $test f8desc] [a red]$m8[a]"
set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]"
} else {
set d8 "[a+ yellow bold][dict get $test f8desc] [a red]$m8[a]"
set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]"
}
append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8"
}

2
src/modules/punk/aliascore-999999.0a1.0.tm
Unescape View File

@ -118,6 +118,7 @@ tcl::namespace::eval punk::aliascore {
pdict ::punk::lib::pdict\
plist {::punk::lib::pdict -roottype list}\
showlist {::punk::lib::showdict -roottype list}\
grepstr ::punk::grepstr\
rehash ::punk::rehash\
showdict ::punk::lib::showdict\
ansistrip ::punk::ansi::ansistrip\
@ -136,6 +137,7 @@ tcl::namespace::eval punk::aliascore {
rmcup ::punk::console::disable_alt_screen\
config ::punk::config\
s ::punk::ns::synopsis\
eg ::punk::ns::eg\
]
#*** !doctools

977
src/modules/punk/ansi-999999.0a1.0.tm
View File

File diff suppressed because it is too large Load Diff

969
src/modules/punk/ansi/colourmap-999999.0a1.0.tm
Unescape View File

@ -0,0 +1,969 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# 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) 2025
#
# @@ Meta Begin
# Application ::punk::ansi::colourmap 999999.0a1.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_::punk::ansi::colourmap 0 999999.0a1.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require ::punk::ansi::colourmap]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of ::punk::ansi::colourmap
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by ::punk::ansi::colourmap
#[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]
tcl::namespace::eval ::punk::ansi::colourmap {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection {Namespace ::punk::ansi::colourmap}]
#[para] Core API functions for ::punk::ansi::colourmap
#[list_begin definitions]
variable PUNKARGS
#----------------------------------------------
#todo - document vars as part of package API
#- or provide a function to return varnames?
#- or wrap each in a function and see if any performance/memory impact? (readonly - so should just be a reference without any copying?)
#TK_colour_map
#TK_colour_map_lookup
#TK_colour_map_merge
#TK_colour_map_reverse
#----------------------------------------------
#significantly slower than tables - but here as a check/test
lappend PUNKARGS [list {
@id -id ::punk::ansi::colourmap::get_rgb_using_tk
@cmd -name punk::ansi::colourmap::get_rgb_using_tk -help\
"This function requires Tk to function, and will call
'package require tk' to load it.
The name argument accepts Tk colour names or hex values
in either #XXX or #XXXXXX format.
Tk colour names can be displayed using the command:
punk::ansi::a? tk ?glob..?
get_rgb_using_tk returns a decimal rgb string delimited with dashes.
e.g
get_rgb_using_tk #FFF
255-255-255
get_rgb_using_tk SlateBlue
106-90-205"
@leaders
name -type string|stringstartswith(#)
}]
proc get_rgb_using_tk {name} {
package require tk
#assuming 'winfo depth .' is always 32 ?
set RGB [winfo rgb . $name]
set rgb [lmap n $RGB {expr {$n / 256}}]
return [join $rgb -]
}
variable TK_colour_map
tcl::dict::set TK_colour_map "alice blue" 240-248-255
tcl::dict::set TK_colour_map AliceBlue 240-248-255
tcl::dict::set TK_colour_map "antique white" 250-235-215
tcl::dict::set TK_colour_map AntiqueWhite 250-235-215
tcl::dict::set TK_colour_map AntiqueWhite1 255-239-219
tcl::dict::set TK_colour_map AntiqueWhite2 238-223-204
tcl::dict::set TK_colour_map AntiqueWhite3 205-192-176
tcl::dict::set TK_colour_map AntiqueWhite4 139-131-120
tcl::dict::set TK_colour_map aqua 0-255-255
tcl::dict::set TK_colour_map aquamarine 127-255-212
tcl::dict::set TK_colour_map aquamarine1 127-255-212
tcl::dict::set TK_colour_map aquamarine2 118-238-198
tcl::dict::set TK_colour_map aquamarine3 102-205-170
tcl::dict::set TK_colour_map aquamarine4 69-139-16
tcl::dict::set TK_colour_map azure 240-255-255
tcl::dict::set TK_colour_map azure1 240-255-255
tcl::dict::set TK_colour_map azure2 224-238-238
tcl::dict::set TK_colour_map azure3 193-205-205
tcl::dict::set TK_colour_map azure4 131-139-139
tcl::dict::set TK_colour_map beige 245-245-220
tcl::dict::set TK_colour_map bisque 255-228-196
tcl::dict::set TK_colour_map bisque1 255-228-196
tcl::dict::set TK_colour_map bisque2 238-213-183
tcl::dict::set TK_colour_map bisque3 205-183-158
tcl::dict::set TK_colour_map bisque4 139-125-107
tcl::dict::set TK_colour_map black 0-0-0
tcl::dict::set TK_colour_map "blanched almond" 255-235-205
tcl::dict::set TK_colour_map BlanchedAlmond 255-235-205
tcl::dict::set TK_colour_map blue 0-0-255
tcl::dict::set TK_colour_map "blue violet" 138-43-226
tcl::dict::set TK_colour_map blue1 0-0-255
tcl::dict::set TK_colour_map blue2 0-0-238
tcl::dict::set TK_colour_map blue3 0-0-205
tcl::dict::set TK_colour_map blue4 0-0-139
tcl::dict::set TK_colour_map BlueViolet 138-43-226
tcl::dict::set TK_colour_map brown 165-42-42
tcl::dict::set TK_colour_map brown1 255-64-64
tcl::dict::set TK_colour_map brown2 238-59-59
tcl::dict::set TK_colour_map brown3 205-51-51
tcl::dict::set TK_colour_map brown4 139-35-35
tcl::dict::set TK_colour_map burlywood 222-184-135
tcl::dict::set TK_colour_map burlywood1 255-211-155
tcl::dict::set TK_colour_map burlywood2 238-197-145
tcl::dict::set TK_colour_map burlywood3 205-170-125
tcl::dict::set TK_colour_map burlywood4 139-115-85
tcl::dict::set TK_colour_map "cadet blue" 95-158-160
tcl::dict::set TK_colour_map CadetBlue 95-158-160
tcl::dict::set TK_colour_map CadetBlue1 152-245-255
tcl::dict::set TK_colour_map CadetBlue2 142-229-238
tcl::dict::set TK_colour_map CadetBlue3 122-197-205
tcl::dict::set TK_colour_map CadetBlue4 83-134-139
tcl::dict::set TK_colour_map chartreuse 127-255-0
tcl::dict::set TK_colour_map chartreuse1 127-255-0
tcl::dict::set TK_colour_map chartreuse2 118-238-0
tcl::dict::set TK_colour_map chartreuse3 102-205-0
tcl::dict::set TK_colour_map chartreuse4 69-139-0
tcl::dict::set TK_colour_map chocolate 210-105-30
tcl::dict::set TK_colour_map chocolate1 255-127-36
tcl::dict::set TK_colour_map chocolate2 238-118-33
tcl::dict::set TK_colour_map chocolate3 205-102-29
tcl::dict::set TK_colour_map chocolate4 139-69-19
tcl::dict::set TK_colour_map coral 255-127-80
tcl::dict::set TK_colour_map coral1 255-114-86
tcl::dict::set TK_colour_map coral2 238-106-80
tcl::dict::set TK_colour_map coral3 205-91-69
tcl::dict::set TK_colour_map coral4 139-62-47
tcl::dict::set TK_colour_map "cornflower blue" 100-149-237
tcl::dict::set TK_colour_map CornflowerBlue 100-149-237
tcl::dict::set TK_colour_map cornsilk 255-248-220
tcl::dict::set TK_colour_map cornsilk1 255-248-220
tcl::dict::set TK_colour_map cornsilk2 238-232-205
tcl::dict::set TK_colour_map cornsilk3 205-200-177
tcl::dict::set TK_colour_map cornsilk4 139-136-120
tcl::dict::set TK_colour_map crimson 220-20-60
tcl::dict::set TK_colour_map cyan 0-255-255
tcl::dict::set TK_colour_map cyan1 0-255-255
tcl::dict::set TK_colour_map cyan2 0-238-238
tcl::dict::set TK_colour_map cyan3 0-205-205
tcl::dict::set TK_colour_map cyan4 0-139-139
tcl::dict::set TK_colour_map "dark blue" 0-0-139
tcl::dict::set TK_colour_map "dark cyan" 0-139-139
tcl::dict::set TK_colour_map "dark goldenrod" 184-134-11
tcl::dict::set TK_colour_map "dark gray" 169-169-169
tcl::dict::set TK_colour_map "dark green" 0-100-0
tcl::dict::set TK_colour_map "dark grey" 169-169-169
tcl::dict::set TK_colour_map "dark khaki" 189-183-107
tcl::dict::set TK_colour_map "dark magenta" 139-0-139
tcl::dict::set TK_colour_map "dark olive green" 85-107-47
tcl::dict::set TK_colour_map "dark orange" 255-140-0
tcl::dict::set TK_colour_map "dark orchid" 153-50-204
tcl::dict::set TK_colour_map "dark red" 139-0-0
tcl::dict::set TK_colour_map "dark salmon" 233-150-122
tcl::dict::set TK_colour_map "dark sea green" 143-188-143
tcl::dict::set TK_colour_map "dark slate blue" 72-61-139
tcl::dict::set TK_colour_map "dark slate gray" 47-79-79
tcl::dict::set TK_colour_map "dark slate grey" 47-79-79
tcl::dict::set TK_colour_map "dark turquoise" 0-206-209
tcl::dict::set TK_colour_map "dark violet" 148-0-211
tcl::dict::set TK_colour_map DarkBlue 0-0-139
tcl::dict::set TK_colour_map DarkCyan 0-139-139
tcl::dict::set TK_colour_map DarkGoldenrod 184-134-11
tcl::dict::set TK_colour_map DarkGoldenrod1 255-185-15
tcl::dict::set TK_colour_map DarkGoldenrod2 238-173-14
tcl::dict::set TK_colour_map DarkGoldenrod3 205-149-12
tcl::dict::set TK_colour_map DarkGoldenrod4 139-101-8
tcl::dict::set TK_colour_map DarkGray 169-169-169
tcl::dict::set TK_colour_map DarkGreen 0-100-0
tcl::dict::set TK_colour_map DarkGrey 169-169-169
tcl::dict::set TK_colour_map DarkKhaki 189-183-107
tcl::dict::set TK_colour_map DarkMagenta 139-0-139
tcl::dict::set TK_colour_map DarkOliveGreen 85-107-47
tcl::dict::set TK_colour_map DarkOliveGreen1 202-255-112
tcl::dict::set TK_colour_map DarkOliveGreen2 188-238-104
tcl::dict::set TK_colour_map DarkOliveGreen3 162-205-90
tcl::dict::set TK_colour_map DarkOliveGreen4 110-139-61
tcl::dict::set TK_colour_map DarkOrange 255-140-0
tcl::dict::set TK_colour_map DarkOrange1 255-127-0
tcl::dict::set TK_colour_map DarkOrange2 238-118-0
tcl::dict::set TK_colour_map DarkOrange3 205-102-0
tcl::dict::set TK_colour_map DarkOrange4 139-69-0
tcl::dict::set TK_colour_map DarkOrchid 153-50-204
tcl::dict::set TK_colour_map DarkOrchid1 191-62-255
tcl::dict::set TK_colour_map DarkOrchid2 178-58-238
tcl::dict::set TK_colour_map DarkOrchid3 154-50-205
tcl::dict::set TK_colour_map DarkOrchid4 104-34-139
tcl::dict::set TK_colour_map DarkRed 139-0-0
tcl::dict::set TK_colour_map DarkSalmon 233-150-122
tcl::dict::set TK_colour_map DarkSeaGreen 43-188-143
tcl::dict::set TK_colour_map DarkSeaGreen1 193-255-193
tcl::dict::set TK_colour_map DarkSeaGreen2 180-238-180
tcl::dict::set TK_colour_map DarkSeaGreen3 155-205-155
tcl::dict::set TK_colour_map DarkSeaGreen4 105-139-105
tcl::dict::set TK_colour_map DarkSlateBlue 72-61-139
tcl::dict::set TK_colour_map DarkSlateGray 47-79-79
tcl::dict::set TK_colour_map DarkSlateGray1 151-255-255
tcl::dict::set TK_colour_map DarkSlateGray2 141-238-238
tcl::dict::set TK_colour_map DarkSlateGray3 121-205-205
tcl::dict::set TK_colour_map DarkSlateGray4 82-139-139
tcl::dict::set TK_colour_map DarkSlateGrey 47-79-79
tcl::dict::set TK_colour_map DarkTurquoise 0-206-209
tcl::dict::set TK_colour_map DarkViolet 148-0-211
tcl::dict::set TK_colour_map "deep pink" 255-20-147
tcl::dict::set TK_colour_map "deep sky blue" 0-191-255
tcl::dict::set TK_colour_map DeepPink 255-20-147
tcl::dict::set TK_colour_map DeepPink1 255-20-147
tcl::dict::set TK_colour_map DeepPink2 238-18-137
tcl::dict::set TK_colour_map DeepPink3 205-16-118
tcl::dict::set TK_colour_map DeepPink4 139-10-80
tcl::dict::set TK_colour_map DeepSkyBlue 0-191-255
tcl::dict::set TK_colour_map DeepSkyBlue1 0-191-255
tcl::dict::set TK_colour_map DeepSkyBlue2 0-178-238
tcl::dict::set TK_colour_map DeepSkyBlue3 0-154-205
tcl::dict::set TK_colour_map DeepSkyBlue4 0-104-139
tcl::dict::set TK_colour_map "dim gray" 105-105-105
tcl::dict::set TK_colour_map "dim grey" 105-105-105
tcl::dict::set TK_colour_map DimGray 105-105-105
tcl::dict::set TK_colour_map DimGrey 105-105-105
tcl::dict::set TK_colour_map "dodger blue" 30-144-255
tcl::dict::set TK_colour_map DodgerBlue 30-144-255
tcl::dict::set TK_colour_map DodgerBlue1 30-144-255
tcl::dict::set TK_colour_map DodgerBlue2 28-134-238
tcl::dict::set TK_colour_map DodgerBlue3 24-116-205
tcl::dict::set TK_colour_map DodgerBlue4 16-78-139
tcl::dict::set TK_colour_map firebrick 178-34-34
tcl::dict::set TK_colour_map firebrick1 255-48-48
tcl::dict::set TK_colour_map firebrick2 238-44-44
tcl::dict::set TK_colour_map firebrick3 205-38-38
tcl::dict::set TK_colour_map firebrick4 139-26-26
tcl::dict::set TK_colour_map "floral white" 255-250-240
tcl::dict::set TK_colour_map FloralWhite 255-250-240
tcl::dict::set TK_colour_map "forest green" 34-139-34
tcl::dict::set TK_colour_map ForestGreen 34-139-34
tcl::dict::set TK_colour_map fuchsia 255-0-255
tcl::dict::set TK_colour_map gainsboro 220-220-220
tcl::dict::set TK_colour_map "ghost white" 248-248-255
tcl::dict::set TK_colour_map GhostWhite 248-248-255
tcl::dict::set TK_colour_map gold 255-215-0
tcl::dict::set TK_colour_map gold1 255-215-0
tcl::dict::set TK_colour_map gold2 238-201-0
tcl::dict::set TK_colour_map gold3 205-173-0
tcl::dict::set TK_colour_map gold4 139-117-0
tcl::dict::set TK_colour_map goldenrod 218-165-32
tcl::dict::set TK_colour_map goldenrod1 255-193-37
tcl::dict::set TK_colour_map goldenrod2 238-180-34
tcl::dict::set TK_colour_map goldenrod3 205-155-29
tcl::dict::set TK_colour_map goldenrod4 139-105-20
tcl::dict::set TK_colour_map gray 128-128-128
tcl::dict::set TK_colour_map gray0 0-0-0
tcl::dict::set TK_colour_map gray1 3-3-3
tcl::dict::set TK_colour_map gray2 5-5-5
tcl::dict::set TK_colour_map gray3 8-8-8
tcl::dict::set TK_colour_map gray4 10-10-10
tcl::dict::set TK_colour_map gray5 13-13-13
tcl::dict::set TK_colour_map gray6 15-15-15
tcl::dict::set TK_colour_map gray7 18-18-18
tcl::dict::set TK_colour_map gray8 20-20-20
tcl::dict::set TK_colour_map gray9 23-23-23
tcl::dict::set TK_colour_map gray10 26-26-26
tcl::dict::set TK_colour_map gray11 28-28-28
tcl::dict::set TK_colour_map gray12 31-31-31
tcl::dict::set TK_colour_map gray13 33-33-33
tcl::dict::set TK_colour_map gray14 36-36-36
tcl::dict::set TK_colour_map gray15 38-38-38
tcl::dict::set TK_colour_map gray16 41-41-41
tcl::dict::set TK_colour_map gray17 43-43-43
tcl::dict::set TK_colour_map gray18 46-46-46
tcl::dict::set TK_colour_map gray19 48-48-48
tcl::dict::set TK_colour_map gray20 51-51-51
tcl::dict::set TK_colour_map gray21 54-54-54
tcl::dict::set TK_colour_map gray22 56-56-56
tcl::dict::set TK_colour_map gray23 59-59-59
tcl::dict::set TK_colour_map gray24 61-61-61
tcl::dict::set TK_colour_map gray25 64-64-64
tcl::dict::set TK_colour_map gray26 66-66-66
tcl::dict::set TK_colour_map gray27 69-69-69
tcl::dict::set TK_colour_map gray28 71-71-71
tcl::dict::set TK_colour_map gray29 74-74-74
tcl::dict::set TK_colour_map gray30 77-77-77
tcl::dict::set TK_colour_map gray31 79-79-79
tcl::dict::set TK_colour_map gray32 82-82-82
tcl::dict::set TK_colour_map gray33 84-84-84
tcl::dict::set TK_colour_map gray34 87-87-87
tcl::dict::set TK_colour_map gray35 89-89-89
tcl::dict::set TK_colour_map gray36 92-92-92
tcl::dict::set TK_colour_map gray37 94-94-94
tcl::dict::set TK_colour_map gray38 97-97-97
tcl::dict::set TK_colour_map gray39 99-99-99
tcl::dict::set TK_colour_map gray40 102-102-102
tcl::dict::set TK_colour_map gray41 105-105-105
tcl::dict::set TK_colour_map gray42 107-107-107
tcl::dict::set TK_colour_map gray43 110-110-110
tcl::dict::set TK_colour_map gray44 112-112-112
tcl::dict::set TK_colour_map gray45 115-115-115
tcl::dict::set TK_colour_map gray46 117-117-117
tcl::dict::set TK_colour_map gray47 120-120-120
tcl::dict::set TK_colour_map gray48 122-122-122
tcl::dict::set TK_colour_map gray49 125-125-125
tcl::dict::set TK_colour_map gray50 127-127-127
tcl::dict::set TK_colour_map gray51 130-130-130
tcl::dict::set TK_colour_map gray52 133-133-133
tcl::dict::set TK_colour_map gray53 135-135-135
tcl::dict::set TK_colour_map gray54 138-138-138
tcl::dict::set TK_colour_map gray55 140-140-140
tcl::dict::set TK_colour_map gray56 143-143-143
tcl::dict::set TK_colour_map gray57 145-145-145
tcl::dict::set TK_colour_map gray58 148-148-148
tcl::dict::set TK_colour_map gray59 150-150-150
tcl::dict::set TK_colour_map gray60 153-153-153
tcl::dict::set TK_colour_map gray61 156-156-156
tcl::dict::set TK_colour_map gray62 158-158-158
tcl::dict::set TK_colour_map gray63 161-161-161
tcl::dict::set TK_colour_map gray64 163-163-163
tcl::dict::set TK_colour_map gray65 166-166-166
tcl::dict::set TK_colour_map gray66 168-168-168
tcl::dict::set TK_colour_map gray67 171-171-171
tcl::dict::set TK_colour_map gray68 173-173-173
tcl::dict::set TK_colour_map gray69 176-176-176
tcl::dict::set TK_colour_map gray70 179-179-179
tcl::dict::set TK_colour_map gray71 181-181-181
tcl::dict::set TK_colour_map gray72 184-184-184
tcl::dict::set TK_colour_map gray73 186-186-186
tcl::dict::set TK_colour_map gray74 189-189-189
tcl::dict::set TK_colour_map gray75 191-191-191
tcl::dict::set TK_colour_map gray76 194-194-194
tcl::dict::set TK_colour_map gray77 196-196-196
tcl::dict::set TK_colour_map gray78 199-199-199
tcl::dict::set TK_colour_map gray79 201-201-201
tcl::dict::set TK_colour_map gray80 204-204-204
tcl::dict::set TK_colour_map gray81 207-207-207
tcl::dict::set TK_colour_map gray82 209-209-209
tcl::dict::set TK_colour_map gray83 212-212-212
tcl::dict::set TK_colour_map gray84 214-214-214
tcl::dict::set TK_colour_map gray85 217-217-217
tcl::dict::set TK_colour_map gray86 219-219-219
tcl::dict::set TK_colour_map gray87 222-222-222
tcl::dict::set TK_colour_map gray88 224-224-224
tcl::dict::set TK_colour_map gray89 227-227-227
tcl::dict::set TK_colour_map gray90 229-229-229
tcl::dict::set TK_colour_map gray91 232-232-232
tcl::dict::set TK_colour_map gray92 235-235-235
tcl::dict::set TK_colour_map gray93 237-237-237
tcl::dict::set TK_colour_map gray94 240-240-240
tcl::dict::set TK_colour_map gray95 242-242-242
tcl::dict::set TK_colour_map gray96 245-245-245
tcl::dict::set TK_colour_map gray97 247-247-247
tcl::dict::set TK_colour_map gray98 250-250-250
tcl::dict::set TK_colour_map gray99 252-252-252
tcl::dict::set TK_colour_map gray100 255-255-255
tcl::dict::set TK_colour_map green 0-128-0
tcl::dict::set TK_colour_map "green yellow" 173-255-47
tcl::dict::set TK_colour_map green1 0-255-0
tcl::dict::set TK_colour_map green2 0-238-0
tcl::dict::set TK_colour_map green3 0-205-0
tcl::dict::set TK_colour_map green4 0-139-0
tcl::dict::set TK_colour_map GreenYellow 173-255-47
tcl::dict::set TK_colour_map grey 128-128-128
tcl::dict::set TK_colour_map grey0 0-0-0
tcl::dict::set TK_colour_map grey1 3-3-3
tcl::dict::set TK_colour_map grey2 5-5-5
tcl::dict::set TK_colour_map grey3 8-8-8
tcl::dict::set TK_colour_map grey4 10-10-10
tcl::dict::set TK_colour_map grey5 13-13-13
tcl::dict::set TK_colour_map grey6 15-15-15
tcl::dict::set TK_colour_map grey7 18-18-18
tcl::dict::set TK_colour_map grey8 20-20-20
tcl::dict::set TK_colour_map grey9 23-23-23
tcl::dict::set TK_colour_map grey10 26-26-26
tcl::dict::set TK_colour_map grey11 28-28-28
tcl::dict::set TK_colour_map grey12 31-31-31
tcl::dict::set TK_colour_map grey13 33-33-33
tcl::dict::set TK_colour_map grey14 36-36-36
tcl::dict::set TK_colour_map grey15 38-38-38
tcl::dict::set TK_colour_map grey16 41-41-41
tcl::dict::set TK_colour_map grey17 43-43-43
tcl::dict::set TK_colour_map grey18 46-46-46
tcl::dict::set TK_colour_map grey19 48-48-48
tcl::dict::set TK_colour_map grey20 51-51-51
tcl::dict::set TK_colour_map grey21 54-54-54
tcl::dict::set TK_colour_map grey22 56-56-56
tcl::dict::set TK_colour_map grey23 59-59-59
tcl::dict::set TK_colour_map grey24 61-61-61
tcl::dict::set TK_colour_map grey25 64-64-64
tcl::dict::set TK_colour_map grey26 66-66-66
tcl::dict::set TK_colour_map grey27 69-69-69
tcl::dict::set TK_colour_map grey28 71-71-71
tcl::dict::set TK_colour_map grey29 74-74-74
tcl::dict::set TK_colour_map grey30 77-77-77
tcl::dict::set TK_colour_map grey31 79-79-79
tcl::dict::set TK_colour_map grey32 82-82-82
tcl::dict::set TK_colour_map grey33 84-84-84
tcl::dict::set TK_colour_map grey34 87-87-87
tcl::dict::set TK_colour_map grey35 89-89-89
tcl::dict::set TK_colour_map grey36 92-92-92
tcl::dict::set TK_colour_map grey37 94-94-94
tcl::dict::set TK_colour_map grey38 97-97-97
tcl::dict::set TK_colour_map grey39 99-99-99
tcl::dict::set TK_colour_map grey40 102-102-102
tcl::dict::set TK_colour_map grey41 105-105-105
tcl::dict::set TK_colour_map grey42 107-107-107
tcl::dict::set TK_colour_map grey43 110-110-110
tcl::dict::set TK_colour_map grey44 112-112-112
tcl::dict::set TK_colour_map grey45 115-115-115
tcl::dict::set TK_colour_map grey46 117-117-117
tcl::dict::set TK_colour_map grey47 120-120-120
tcl::dict::set TK_colour_map grey48 122-122-122
tcl::dict::set TK_colour_map grey49 125-125-125
tcl::dict::set TK_colour_map grey50 127-127-127
tcl::dict::set TK_colour_map grey51 130-130-130
tcl::dict::set TK_colour_map grey52 133-133-133
tcl::dict::set TK_colour_map grey53 135-135-135
tcl::dict::set TK_colour_map grey54 138-138-138
tcl::dict::set TK_colour_map grey55 140-140-140
tcl::dict::set TK_colour_map grey56 143-143-143
tcl::dict::set TK_colour_map grey57 145-145-145
tcl::dict::set TK_colour_map grey58 148-148-148
tcl::dict::set TK_colour_map grey59 150-150-150
tcl::dict::set TK_colour_map grey60 153-153-153
tcl::dict::set TK_colour_map grey61 156-156-156
tcl::dict::set TK_colour_map grey62 158-158-158
tcl::dict::set TK_colour_map grey63 161-161-161
tcl::dict::set TK_colour_map grey64 163-163-163
tcl::dict::set TK_colour_map grey65 166-166-166
tcl::dict::set TK_colour_map grey66 168-168-168
tcl::dict::set TK_colour_map grey67 171-171-171
tcl::dict::set TK_colour_map grey68 173-173-173
tcl::dict::set TK_colour_map grey69 176-176-176
tcl::dict::set TK_colour_map grey70 179-179-179
tcl::dict::set TK_colour_map grey71 181-181-181
tcl::dict::set TK_colour_map grey72 184-184-184
tcl::dict::set TK_colour_map grey73 186-186-186
tcl::dict::set TK_colour_map grey74 189-189-189
tcl::dict::set TK_colour_map grey75 191-191-191
tcl::dict::set TK_colour_map grey76 194-194-194
tcl::dict::set TK_colour_map grey77 196-196-196
tcl::dict::set TK_colour_map grey78 199-199-199
tcl::dict::set TK_colour_map grey79 201-201-201
tcl::dict::set TK_colour_map grey80 204-204-204
tcl::dict::set TK_colour_map grey81 207-207-207
tcl::dict::set TK_colour_map grey82 209-209-209
tcl::dict::set TK_colour_map grey83 212-212-212
tcl::dict::set TK_colour_map grey84 214-214-214
tcl::dict::set TK_colour_map grey85 217-217-217
tcl::dict::set TK_colour_map grey86 219-219-219
tcl::dict::set TK_colour_map grey87 222-222-222
tcl::dict::set TK_colour_map grey88 224-224-224
tcl::dict::set TK_colour_map grey89 227-227-227
tcl::dict::set TK_colour_map grey90 229-229-229
tcl::dict::set TK_colour_map grey91 232-232-232
tcl::dict::set TK_colour_map grey92 235-235-235
tcl::dict::set TK_colour_map grey93 237-237-237
tcl::dict::set TK_colour_map grey94 240-240-240
tcl::dict::set TK_colour_map grey95 242-242-242
tcl::dict::set TK_colour_map grey96 245-245-245
tcl::dict::set TK_colour_map grey97 247-247-247
tcl::dict::set TK_colour_map grey98 250-250-250
tcl::dict::set TK_colour_map grey99 252-252-252
tcl::dict::set TK_colour_map grey100 255-255-255
tcl::dict::set TK_colour_map honeydew 240-255-240
tcl::dict::set TK_colour_map honeydew1 240-255-240
tcl::dict::set TK_colour_map honeydew2 224-238-224
tcl::dict::set TK_colour_map honeydew3 193-205-193
tcl::dict::set TK_colour_map honeydew4 131-139-131
tcl::dict::set TK_colour_map "hot pink" 255-105-180
tcl::dict::set TK_colour_map HotPink 255-105-180
tcl::dict::set TK_colour_map HotPink1 255-110-180
tcl::dict::set TK_colour_map HotPink2 238-106-167
tcl::dict::set TK_colour_map HotPink3 205-96-144
tcl::dict::set TK_colour_map HotPink4 139-58-98
tcl::dict::set TK_colour_map "indian red" 205-92-92
tcl::dict::set TK_colour_map IndianRed 205-92-92
tcl::dict::set TK_colour_map IndianRed1 255-106-106
tcl::dict::set TK_colour_map IndianRed2 238-99-99
tcl::dict::set TK_colour_map IndianRed3 205-85-85
tcl::dict::set TK_colour_map IndianRed4 139-58-58
tcl::dict::set TK_colour_map indigo 75-0-130
tcl::dict::set TK_colour_map ivory 255-255-240
tcl::dict::set TK_colour_map ivory1 255-255-240
tcl::dict::set TK_colour_map ivory2 238-238-224
tcl::dict::set TK_colour_map ivory3 205-205-193
tcl::dict::set TK_colour_map ivory4 139-139-131
tcl::dict::set TK_colour_map khaki 240-230-140
tcl::dict::set TK_colour_map khaki1 255-246-143
tcl::dict::set TK_colour_map khaki2 238-230-133
tcl::dict::set TK_colour_map khaki3 205-198-115
tcl::dict::set TK_colour_map khaki4 139-134-78
tcl::dict::set TK_colour_map lavender 230-230-250
tcl::dict::set TK_colour_map "lavender blush" 255-240-245
tcl::dict::set TK_colour_map LavenderBlush 255-240-245
tcl::dict::set TK_colour_map LavenderBlush1 255-240-245
tcl::dict::set TK_colour_map LavenderBlush2 238-224-229
tcl::dict::set TK_colour_map LavenderBlush3 205-193-197
tcl::dict::set TK_colour_map LavenderBlush4 139-131-134
tcl::dict::set TK_colour_map "lawn green" 124-252-0
tcl::dict::set TK_colour_map LawnGreen 124-252-0
tcl::dict::set TK_colour_map "lemon chiffon" 255-250-205
tcl::dict::set TK_colour_map LemonChiffon 255-250-205
tcl::dict::set TK_colour_map LemonChiffon1 255-250-205
tcl::dict::set TK_colour_map LemonChiffon2 238-233-191
tcl::dict::set TK_colour_map LemonChiffon3 205-201-165
tcl::dict::set TK_colour_map LemonChiffon4 139-137-112
tcl::dict::set TK_colour_map "light blue" 173-216-230
tcl::dict::set TK_colour_map "light coral" 240-128-128
tcl::dict::set TK_colour_map "light cyan" 224-255-255
tcl::dict::set TK_colour_map "light goldenrod" 238-221-130
tcl::dict::set TK_colour_map "light goldenrod yellow" 250-250-210
tcl::dict::set TK_colour_map "light gray" 211-211-211
tcl::dict::set TK_colour_map "light green" 144-238-144
tcl::dict::set TK_colour_map "light grey" 211-211-211
tcl::dict::set TK_colour_map "light pink" 255-182-193
tcl::dict::set TK_colour_map "light salmon" 255-160-122
tcl::dict::set TK_colour_map "light sea green" 32-178-170
tcl::dict::set TK_colour_map "light sky blue" 135-206-250
tcl::dict::set TK_colour_map "light slate blue" 132-112-255
tcl::dict::set TK_colour_map "light slate gray" 119-136-153
tcl::dict::set TK_colour_map "light slate grey" 119-136-153
tcl::dict::set TK_colour_map "light steel blue" 176-196-222
tcl::dict::set TK_colour_map "light yellow" 255-255-224
tcl::dict::set TK_colour_map LightBlue 173-216-230
tcl::dict::set TK_colour_map LightBlue1 191-239-255
tcl::dict::set TK_colour_map LightBlue2 178-223-238
tcl::dict::set TK_colour_map LightBlue3 154-192-205
tcl::dict::set TK_colour_map LightBlue4 104-131-139
tcl::dict::set TK_colour_map LightCoral 240-128-128
tcl::dict::set TK_colour_map LightCyan 224-255-255
tcl::dict::set TK_colour_map LightCyan1 224-255-255
tcl::dict::set TK_colour_map LightCyan2 209-238-238
tcl::dict::set TK_colour_map LightCyan3 180-205-205
tcl::dict::set TK_colour_map LightCyan4 122-139-139
tcl::dict::set TK_colour_map LightGoldenrod 238-221-130
tcl::dict::set TK_colour_map LightGoldenrod1 255-236-139
tcl::dict::set TK_colour_map LightGoldenrod2 238-220-130
tcl::dict::set TK_colour_map LightGoldenrod3 205-190-112
tcl::dict::set TK_colour_map LightGoldenrod4 139-129-76
tcl::dict::set TK_colour_map LightGoldenrodYellow 250-250-210
tcl::dict::set TK_colour_map LightGray 211-211-211
tcl::dict::set TK_colour_map LightGreen 144-238-144
tcl::dict::set TK_colour_map LightGrey 211-211-211
tcl::dict::set TK_colour_map LightPink 255-182-193
tcl::dict::set TK_colour_map LightPink1 255-174-185
tcl::dict::set TK_colour_map LightPink2 238-162-173
tcl::dict::set TK_colour_map LightPink3 205-140-149
tcl::dict::set TK_colour_map LightPink4 139-95-101
tcl::dict::set TK_colour_map LightSalmon 255-160-122
tcl::dict::set TK_colour_map LightSalmon1 255-160-122
tcl::dict::set TK_colour_map LightSalmon2 238-149-114
tcl::dict::set TK_colour_map LightSalmon3 205-129-98
tcl::dict::set TK_colour_map LightSalmon4 139-87-66
tcl::dict::set TK_colour_map LightSeaGreen 32-178-170
tcl::dict::set TK_colour_map LightSkyBlue 135-206-250
tcl::dict::set TK_colour_map LightSkyBlue1 176-226-255
tcl::dict::set TK_colour_map LightSkyBlue2 164-211-238
tcl::dict::set TK_colour_map LightSkyBlue3 141-182-205
tcl::dict::set TK_colour_map LightSkyBlue4 96-123-139
tcl::dict::set TK_colour_map LightSlateBlue 132-112-255
tcl::dict::set TK_colour_map LightSlateGray 119-136-153
tcl::dict::set TK_colour_map LightSlateGrey 119-136-153
tcl::dict::set TK_colour_map LightSteelBlue 176-196-222
tcl::dict::set TK_colour_map LightSteelBlue1 202-225-255
tcl::dict::set TK_colour_map LightSteelBlue2 188-210-238
tcl::dict::set TK_colour_map LightSteelBlue3 162-181-205
tcl::dict::set TK_colour_map LightSteelBlue4 110-123-139
tcl::dict::set TK_colour_map LightYellow 255-255-224
tcl::dict::set TK_colour_map LightYellow1 255-255-224
tcl::dict::set TK_colour_map LightYellow2 238-238-209
tcl::dict::set TK_colour_map LightYellow3 205-205-180
tcl::dict::set TK_colour_map LightYellow4 139-139-122
tcl::dict::set TK_colour_map lime 0-255-0
tcl::dict::set TK_colour_map "lime green" 50-205-50
tcl::dict::set TK_colour_map LimeGreen 50-205-50
tcl::dict::set TK_colour_map linen 250-240-230
tcl::dict::set TK_colour_map magenta 255-0-255
tcl::dict::set TK_colour_map magenta1 255-0-255
tcl::dict::set TK_colour_map magenta2 238-0-238
tcl::dict::set TK_colour_map magenta3 205-0-205
tcl::dict::set TK_colour_map magenta4 139-0-139
tcl::dict::set TK_colour_map maroon 128-0-0
tcl::dict::set TK_colour_map maroon1 255-52-179
tcl::dict::set TK_colour_map maroon2 238-48-167
tcl::dict::set TK_colour_map maroon3 205-41-144
tcl::dict::set TK_colour_map maroon4 139-28-98
tcl::dict::set TK_colour_map "medium aquamarine" 102-205-170
tcl::dict::set TK_colour_map "medium blue" 0-0-205
tcl::dict::set TK_colour_map "medium orchid" 186-85-211
tcl::dict::set TK_colour_map "medium purple" 147-112-219
tcl::dict::set TK_colour_map "medium sea green" 60-179-113
tcl::dict::set TK_colour_map "medium slate blue" 123-104-238
tcl::dict::set TK_colour_map "medium spring green" 0-250-154
tcl::dict::set TK_colour_map "medium turquoise" 72-209-204
tcl::dict::set TK_colour_map "medium violet red" 199-21-133
tcl::dict::set TK_colour_map MediumAquamarine 102-205-170
tcl::dict::set TK_colour_map MediumBlue 0-0-205
tcl::dict::set TK_colour_map MediumOrchid 186-85-211
tcl::dict::set TK_colour_map MediumOrchid1 224-102-255
tcl::dict::set TK_colour_map MediumOrchid2 209-95-238
tcl::dict::set TK_colour_map MediumOrchid3 180-82-205
tcl::dict::set TK_colour_map MediumOrchid4 122-55-139
tcl::dict::set TK_colour_map MediumPurple 147-112-219
tcl::dict::set TK_colour_map MediumPurple1 171-130-255
tcl::dict::set TK_colour_map MediumPurple2 159-121-238
tcl::dict::set TK_colour_map MediumPurple3 137-104-205
tcl::dict::set TK_colour_map MediumPurple4 93-71-139
tcl::dict::set TK_colour_map MediumSeaGreen 60-179-113
tcl::dict::set TK_colour_map MediumSlateBlue 123-104-238
tcl::dict::set TK_colour_map MediumSpringGreen 0-250-154
tcl::dict::set TK_colour_map MediumTurquoise 72-209-204
tcl::dict::set TK_colour_map MediumVioletRed 199-21-133
tcl::dict::set TK_colour_map "midnight blue" 25-25-112
tcl::dict::set TK_colour_map MidnightBlue 25-25-112
tcl::dict::set TK_colour_map "mint cream" 245-255-250
tcl::dict::set TK_colour_map MintCream 245-255-250
tcl::dict::set TK_colour_map "misty rose" 255-228-225
tcl::dict::set TK_colour_map MistyRose 255-228-225
tcl::dict::set TK_colour_map MistyRose1 255-228-225
tcl::dict::set TK_colour_map MistyRose2 238-213-210
tcl::dict::set TK_colour_map MistyRose3 205-183-181
tcl::dict::set TK_colour_map MistyRose4 139-125-123
tcl::dict::set TK_colour_map moccasin 255-228-181
tcl::dict::set TK_colour_map "navajo white" 255-222-173
tcl::dict::set TK_colour_map NavajoWhite 255-222-173
tcl::dict::set TK_colour_map NavajoWhite1 255-222-173
tcl::dict::set TK_colour_map NavajoWhite2 238-207-161
tcl::dict::set TK_colour_map NavajoWhite3 205-179-139
tcl::dict::set TK_colour_map NavajoWhite4 139-121-94
tcl::dict::set TK_colour_map navy 0-0-128
tcl::dict::set TK_colour_map "navy blue" 0-0-128
tcl::dict::set TK_colour_map NavyBlue 0-0-128
tcl::dict::set TK_colour_map "old lace" 253-245-230
tcl::dict::set TK_colour_map OldLace 253-245-230
tcl::dict::set TK_colour_map olive 128-128-0
tcl::dict::set TK_colour_map "olive drab" 107-142-35
tcl::dict::set TK_colour_map OliveDrab 107-142-35
tcl::dict::set TK_colour_map OliveDrab1 192-255-62
tcl::dict::set TK_colour_map OliveDrab2 179-238-58
tcl::dict::set TK_colour_map OliveDrab3 154-205-50
tcl::dict::set TK_colour_map OliveDrab4 105-139-34
tcl::dict::set TK_colour_map orange 255-165-0
tcl::dict::set TK_colour_map "orange red" 255-69-0
tcl::dict::set TK_colour_map orange1 255-165-0
tcl::dict::set TK_colour_map orange2 238-154-0
tcl::dict::set TK_colour_map orange3 205-133-0
tcl::dict::set TK_colour_map orange4 139-90-0
tcl::dict::set TK_colour_map OrangeRed 255-69-0
tcl::dict::set TK_colour_map OrangeRed1 255-69-0
tcl::dict::set TK_colour_map OrangeRed2 238-64-0
tcl::dict::set TK_colour_map OrangeRed3 205-55-0
tcl::dict::set TK_colour_map OrangeRed4 139-37-0
tcl::dict::set TK_colour_map orchid 218-112-214
tcl::dict::set TK_colour_map orchid1 255-131-250
tcl::dict::set TK_colour_map orchid2 238-122-233
tcl::dict::set TK_colour_map orchid3 205-105-201
tcl::dict::set TK_colour_map orchid4 139-71-137
tcl::dict::set TK_colour_map "pale goldenrod" 238-232-170
tcl::dict::set TK_colour_map "pale green" 152-251-152
tcl::dict::set TK_colour_map "pale turquoise" 175-238-238
tcl::dict::set TK_colour_map "pale violet red" 219-112-147
tcl::dict::set TK_colour_map PaleGoldenrod 238-232-170
tcl::dict::set TK_colour_map PaleGreen 152-251-152
tcl::dict::set TK_colour_map PaleGreen1 154-255-154
tcl::dict::set TK_colour_map PaleGreen2 144-238-144
tcl::dict::set TK_colour_map PaleGreen3 124-205-124
tcl::dict::set TK_colour_map PaleGreen4 84-139-84
tcl::dict::set TK_colour_map PaleTurquoise 175-238-238
tcl::dict::set TK_colour_map PaleTurquoise1 187-255-255
tcl::dict::set TK_colour_map PaleTurquoise2 174-238-238
tcl::dict::set TK_colour_map PaleTurquoise3 150-205-205
tcl::dict::set TK_colour_map PaleTurquoise4 102-139-139
tcl::dict::set TK_colour_map PaleVioletRed 219-112-147
tcl::dict::set TK_colour_map PaleVioletRed1 255-130-171
tcl::dict::set TK_colour_map PaleVioletRed2 238-121-159
tcl::dict::set TK_colour_map PaleVioletRed3 205-104-127
tcl::dict::set TK_colour_map PaleVioletRed4 139-71-93
tcl::dict::set TK_colour_map "papaya whip" 255-239-213
tcl::dict::set TK_colour_map PapayaWhip 255-239-213
tcl::dict::set TK_colour_map "peach puff" 255-218-185
tcl::dict::set TK_colour_map PeachPuff 255-218-185
tcl::dict::set TK_colour_map PeachPuff1 255-218-185
tcl::dict::set TK_colour_map PeachPuff2 238-203-173
tcl::dict::set TK_colour_map PeachPuff3 205-175-149
tcl::dict::set TK_colour_map PeachPuff4 139-119-101
tcl::dict::set TK_colour_map peru 205-133-63
tcl::dict::set TK_colour_map pink 255-192-203
tcl::dict::set TK_colour_map pink1 255-181-197
tcl::dict::set TK_colour_map pink2 238-169-184
tcl::dict::set TK_colour_map pink3 205-145-158
tcl::dict::set TK_colour_map pink4 139-99-108
tcl::dict::set TK_colour_map plum 221-160-221
tcl::dict::set TK_colour_map plum1 255-187-255
tcl::dict::set TK_colour_map plum2 238-174-238
tcl::dict::set TK_colour_map plum3 205-150-205
tcl::dict::set TK_colour_map plum4 139-102-139
tcl::dict::set TK_colour_map "powder blue" 176-224-230
tcl::dict::set TK_colour_map PowderBlue 176-224-230
tcl::dict::set TK_colour_map purple 128-0-128
tcl::dict::set TK_colour_map purple1 155-48-255
tcl::dict::set TK_colour_map purple2 145-44-238
tcl::dict::set TK_colour_map purple3 125-38-205
tcl::dict::set TK_colour_map purple4 85-26-139
tcl::dict::set TK_colour_map red 255-0-0
tcl::dict::set TK_colour_map red1 255-0-0
tcl::dict::set TK_colour_map red2 238-0-0
tcl::dict::set TK_colour_map red3 205-0-0
tcl::dict::set TK_colour_map red4 139-0-0
tcl::dict::set TK_colour_map "rosy brown" 188-143-143
tcl::dict::set TK_colour_map RosyBrown 188-143-143
tcl::dict::set TK_colour_map RosyBrown1 255-193-193
tcl::dict::set TK_colour_map RosyBrown2 238-180-180
tcl::dict::set TK_colour_map RosyBrown3 205-155-155
tcl::dict::set TK_colour_map RosyBrown4 139-105-105
tcl::dict::set TK_colour_map "royal blue" 65-105-225
tcl::dict::set TK_colour_map RoyalBlue 65-105-225
tcl::dict::set TK_colour_map RoyalBlue1 72-118-255
tcl::dict::set TK_colour_map RoyalBlue2 67-110-238
tcl::dict::set TK_colour_map RoyalBlue3 58-95-205
tcl::dict::set TK_colour_map RoyalBlue4 39-64-139
tcl::dict::set TK_colour_map "saddle brown" 139-69-19
tcl::dict::set TK_colour_map SaddleBrown 139-69-19
tcl::dict::set TK_colour_map salmon 250-128-114
tcl::dict::set TK_colour_map salmon1 255-140-105
tcl::dict::set TK_colour_map salmon2 238-130-98
tcl::dict::set TK_colour_map salmon3 205-112-84
tcl::dict::set TK_colour_map salmon4 139-76-57
tcl::dict::set TK_colour_map "sandy brown" 244-164-96
tcl::dict::set TK_colour_map SandyBrown 244-164-96
tcl::dict::set TK_colour_map "sea green" 46-139-87
tcl::dict::set TK_colour_map SeaGreen 46-139-87
tcl::dict::set TK_colour_map SeaGreen1 84-255-159
tcl::dict::set TK_colour_map SeaGreen2 78-238-148
tcl::dict::set TK_colour_map SeaGreen3 67-205-128
tcl::dict::set TK_colour_map SeaGreen4 46-139-87
tcl::dict::set TK_colour_map seashell 255-245-238
tcl::dict::set TK_colour_map seashell1 255-245-238
tcl::dict::set TK_colour_map seashell2 238-229-222
tcl::dict::set TK_colour_map seashell3 205-197-191
tcl::dict::set TK_colour_map seashell4 139-134-130
tcl::dict::set TK_colour_map sienna 160-82-45
tcl::dict::set TK_colour_map sienna1 255-130-71
tcl::dict::set TK_colour_map sienna2 238-121-66
tcl::dict::set TK_colour_map sienna3 205-104-57
tcl::dict::set TK_colour_map sienna4 139-71-38
tcl::dict::set TK_colour_map silver 192-192-192
tcl::dict::set TK_colour_map "sky blue" 135-206-235
tcl::dict::set TK_colour_map SkyBlue 135-206-235
tcl::dict::set TK_colour_map SkyBlue1 135-206-255
tcl::dict::set TK_colour_map SkyBlue2 126-192-238
tcl::dict::set TK_colour_map SkyBlue3 108-166-205
tcl::dict::set TK_colour_map SkyBlue4 74-112-139
tcl::dict::set TK_colour_map "slate blue" 106-90-205
tcl::dict::set TK_colour_map "slate gray" 112-128-144
tcl::dict::set TK_colour_map "slate grey" 112-128-144
tcl::dict::set TK_colour_map SlateBlue 106-90-205
tcl::dict::set TK_colour_map SlateBlue1 131-111-255
tcl::dict::set TK_colour_map SlateBlue2 122-103-238
tcl::dict::set TK_colour_map SlateBlue3 105-89-205
tcl::dict::set TK_colour_map SlateBlue4 71-60-139
tcl::dict::set TK_colour_map SlateGray 112-128-144
tcl::dict::set TK_colour_map SlateGray1 198-226-255
tcl::dict::set TK_colour_map SlateGray2 185-211-238
tcl::dict::set TK_colour_map SlateGray3 159-182-205
tcl::dict::set TK_colour_map SlateGray4 108-123-139
tcl::dict::set TK_colour_map SlateGrey 112-128-144
tcl::dict::set TK_colour_map snow 255-250-250
tcl::dict::set TK_colour_map snow1 255-250-250
tcl::dict::set TK_colour_map snow2 238-233-233
tcl::dict::set TK_colour_map snow3 205-201-201
tcl::dict::set TK_colour_map snow4 139-137-137
tcl::dict::set TK_colour_map "spring green" 0-255-127
tcl::dict::set TK_colour_map SpringGreen 0-255-127
tcl::dict::set TK_colour_map SpringGreen1 0-255-127
tcl::dict::set TK_colour_map SpringGreen2 0-238-118
tcl::dict::set TK_colour_map SpringGreen3 0-205-102
tcl::dict::set TK_colour_map SpringGreen4 0-139-69
tcl::dict::set TK_colour_map "steel blue" 70-130-180
tcl::dict::set TK_colour_map SteelBlue 70-130-180
tcl::dict::set TK_colour_map SteelBlue1 99-184-255
tcl::dict::set TK_colour_map SteelBlue2 92-172-238
tcl::dict::set TK_colour_map SteelBlue3 79-148-205
tcl::dict::set TK_colour_map SteelBlue4 54-100-139
tcl::dict::set TK_colour_map tan 210-180-140
tcl::dict::set TK_colour_map tan1 255-165-79
tcl::dict::set TK_colour_map tan2 238-154-73
tcl::dict::set TK_colour_map tan3 205-133-63
tcl::dict::set TK_colour_map tan4 139-90-43
tcl::dict::set TK_colour_map teal 0-128-128
tcl::dict::set TK_colour_map thistle 216-191-216
tcl::dict::set TK_colour_map thistle1 255-225-255
tcl::dict::set TK_colour_map thistle2 238-210-238
tcl::dict::set TK_colour_map thistle3 205-181-205
tcl::dict::set TK_colour_map thistle4 139-123-139
tcl::dict::set TK_colour_map tomato 255-99-71
tcl::dict::set TK_colour_map tomato1 255-99-71
tcl::dict::set TK_colour_map tomato2 238-92-66
tcl::dict::set TK_colour_map tomato3 205-79-57
tcl::dict::set TK_colour_map tomato4 139-54-38
tcl::dict::set TK_colour_map turquoise 64-224-208
tcl::dict::set TK_colour_map turquoise1 0-245-255
tcl::dict::set TK_colour_map turquoise2 0-229-238
tcl::dict::set TK_colour_map turquoise3 0-197-205
tcl::dict::set TK_colour_map turquoise4 0-134-139
tcl::dict::set TK_colour_map violet 238-130-238
tcl::dict::set TK_colour_map "violet red" 208-32-144
tcl::dict::set TK_colour_map VioletRed 208-32-144
tcl::dict::set TK_colour_map VioletRed1 255-62-150
tcl::dict::set TK_colour_map VioletRed2 238-58-140
tcl::dict::set TK_colour_map VioletRed3 205-50-120
tcl::dict::set TK_colour_map VioletRed4 139-34-82
tcl::dict::set TK_colour_map wheat 245-222-179
tcl::dict::set TK_colour_map wheat1 255-231-186
tcl::dict::set TK_colour_map wheat2 238-216-174
tcl::dict::set TK_colour_map wheat3 205-186-150
tcl::dict::set TK_colour_map wheat4 139-126-102
tcl::dict::set TK_colour_map white 255-255-255
tcl::dict::set TK_colour_map "white smoke" 245-245-245
tcl::dict::set TK_colour_map WhiteSmoke 245-245-245
tcl::dict::set TK_colour_map yellow 255-255-0
tcl::dict::set TK_colour_map "yellow green" 154-205-50
tcl::dict::set TK_colour_map yellow1 255-255-0
tcl::dict::set TK_colour_map yellow2 238-238-0
tcl::dict::set TK_colour_map yellow3 205-205-0
tcl::dict::set TK_colour_map yellow4 139-139-0
tcl::dict::set TK_colour_map YellowGreen 154-205-50
variable TK_colour_map_lookup ;#same dict but with lower-case versions added
set TK_colour_map_lookup $TK_colour_map
dict for {key val} $TK_colour_map {
dict set TK_colour_map_lookup [tcl::string::tolower $key] $val ;#no need to test if already present - just set.
}
variable TK_colour_map_reverse [dict create]
dict for {key val} $TK_colour_map {
dict lappend TK_colour_map_reverse $val $key
}
#using same order as inital colour map
variable TK_colour_map_merge [dict create]
set seen_names [dict create]
dict for {key val} $TK_colour_map {
if {[dict exists $seen_names $key]} {
continue
}
set allnames [dict get $TK_colour_map_reverse $val]
set names [list]
foreach n $allnames {
if {$n ne $key} {
lappend names $n
}
}
dict set TK_colour_map_merge $key [dict create colour $val names $names]
foreach n $names {
dict set seen_names $n 1
}
}
unset seen_names
#*** !doctools
#[list_end] [comment {--- end definitions namespace ::punk::ansi::colourmap ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval ::punk::ansi::colourmap::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace ::punk::ansi::colourmap::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::ansi::colourmap::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# -----------------------------------------------------------------------------
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked
# -----------------------------------------------------------------------------
# variable PUNKARGS
# variable PUNKARGS_aliases
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::punk::ansi::colourmap
}
# -----------------------------------------------------------------------------
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::ansi::colourmap [tcl::namespace::eval ::punk::ansi::colourmap {
variable pkg ::punk::ansi::colourmap
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]

3
src/modules/punk/ansi/colourmap-buildversion.txt
Unescape View File

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

4829
src/modules/punk/args-999999.0a1.0.tm
View File

File diff suppressed because it is too large Load Diff

842
src/modules/punk/args/tclcore-999999.0a1.0.tm
Unescape View File

@ -52,6 +52,7 @@ package require textblock
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package {punk::args}]
#[item] [package {textblock}]
#*** !doctools
#[list_end]
@ -61,38 +62,6 @@ package require textblock
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::args::tclcore::class {
#*** !doctools
#[subsection {Namespace punk::args::tclcore::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
@ -365,6 +334,8 @@ tcl::namespace::eval punk::args::tclcore {
fileName
#todo punk::args::synopsis - show prefix highlighting
mode -type literalprefix(text)|literalprefix(binary) -optional 1
#test
#mode -type {{literalprefix text | literalprefix binary}}
} "@doc -name Manpage: -url [manpage_tcl library]" ]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list {
@ -1345,6 +1316,36 @@ tcl::namespace::eval punk::args::tclcore {
body -type script -typesynopsis ${$I}body<script>${$NI} -optional 0
} "@doc -name Manpage: -url [manpage_tcl dict]" ]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list {
@id -id ::tcl::dict::with
@cmd -name "Builtin: tcl::dict::with" -help\
"Execute the Tcl script in body with the value for each key in dictionaryVariable mapped (in a manner
similarly to dict update) to a variable with the same name. Where one or more keys are available,
these indicate a chain of nested dictionaries, with the innermost dictionary being the one opened out
for the execution of body. As with dict update, making dictionaryVariable unreadable will make the
updates to the dictionary be discarded, and this also happens if the contents of dictionaryVariable
are adjusted so that the chain of dictionaries no longer exists. The result of dict with is (unless
some kind of error occurs) the result of the evaluation of body. If dictionaryVariable indicates an
element that does not exist of an array that has a default value set, the default value and will be
used as the value of the dictionary prior to the updating operation.
The variables are mapped in the scope enclosing the dict with; it is recommended that this command
only be used in a local scope (procedure, lambda term for apply, or method). Because of this, the
variables set by dict with will continue to exist after the command finishes (unless explicitly unset).
Note that the mapping of values to variables does not use traces; changes to the dictionaryVariable's
contents only happen when body terminates.
If the dictionaryVariable contains a value that is not a dictionary at the point when the body
terminates (which can easily happen if the name is the same as any of the keys in dictionary) then an
error occurs at that point. This command is thus not recommended for use when the keys in the
dictionary are expected to clash with the dictionaryVariable name itself. Where the contained key does
map to a dictionary, the net effect is to combine that inner dictionary into the outer dictionary; see
the EXAMPLES for an illustration of this."
@values -min 2 -max -1
dictionaryVariable -type string
key -type any -typesynopsis {${$I}key${$NI}} -optional 1 -multiple 1
body -type script -typesynopsis ${$I}body<script>${$NI} -optional 0
} "@doc -name Manpage: -url [manpage_tcl dict]" ]
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
@ -2178,6 +2179,125 @@ tcl::namespace::eval punk::args::tclcore {
} "@doc -name Manpage: -url [manpage_tcl error]" ]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list {
@id -id ::tcl::build-info
@cmd -name "Builtin: tcl::build-info"\
-summary\
"Build info."\
-help\
"This command provides a way to retrieve information about how Tcl was built.
Without any options, the command returns the Tcl patchlevel, followed by the
'+'-sign, followed by the fossil commit-id followed by a list of dot-separated
tags. If a field is given, this command extracts that field as described below.
Any other field value not mentioned below will always return \"0\"."
@leaders -min 0 -max 1
field -type string -optional 1 -choicecolumns 3\
-choices {
clang commit compiledebug compiler compilestats cplusplus debug gcc icc ilp32 memdebug msvc
nmake no-deprecate no-thread no-optimize objective-c objective-cplusplus patchlevel profile
purify static tommath version zlib
}\
-choicelabels {
clang\
" Returns the clang version number (as 4 digits)
if Tcl is compiled with clang, 0 otherwise."
commit\
" Returns the fossil commit-id where Tcl was
built from."
compiledebug\
" Returns 1 if Tcl is compiled with
${$B}-DTCL_COMPILE_DEBUG${$N}, 0 otherwise."
compiler\
" Returns the compiler name (either clang, gcc,
icc or msvc), followed by a dash and a (4-digit)
version number."
compilestats\
" Returns 1 if Tcl is compiled with
${$B}-DTCL_COMPILE_STATS${$N}, 0 otherwise."
cplusplus\
" Returns 1 if Tcl is compiled with a C++
compiler, 0 otherwise."
debug\
" Returns 1 if Tcl is not compiled with
${$B}-DNDEBUG${$N}, 0 otherwise."
gcc\
" Returns the gcc version number (as 4 digits)
if Tcl is compiled with gcc, 0 otherwise."
icc\
" Returns the icc version number (as 4 digits)
if Tcl is compiled with icc, 0 otherwise."
ilp32\
" Returns 1 if Tcl is compiled such that integers,
longs and pointers are all 32-bit, 0 otherwise."
memdebug\
" Returns 1 if Tcl is compiled with
${$B}-DTCL_MEM_DEBUG${$N}, 0 otherwise."
msvc\
" Returns the msvc version number (as 4 digits)
if Tcl is compiled with msvc, 0 otherwise."
nmake\
" Returns 1 if Tcl is built using nmake,
0 otherwise"
no-deprecate\
" Returns 1 if Tcl is compiled with
${$B}-DTCL_NO_DEPRECATED${$N}, 0 otherwise."
no-thread\
" Returns 1 if Tcl is compiled with
${$B}-DTCL_THREADS${$N}=0, 0 otherwise."
no-optimize\
" Returns 1 if Tcl is not compiled with
${$B}-DTCL_CFG_OPTIMIZED${$N}, 0 otherwise."
objective-c\
" Returns 1 if Tcl is compiled with an
objective-c compiler, 0 otherwise."
objective-cplusplus\
" Returns 1 if Tcl is compiled with an
objective-c++ compiler, 0 otherwise."
patchlevel\
" Returns the Tcl patchlevel, same as
${$B}info patchlevel${$N}."
profile\
" Returns 1 if Tcl is compiled with
${$B}-DTCL_CFG_PROFILED${$N}, 0 otherwise."
purify\
" Returns 1 if Tcl is compiled with
${$B}-DPURIFY${$N}, 0 otherwise."
static\
" Returns 1 if Tcl is compiled as a static
library, 0 otherwise."
tommath\
" Returns the libtommath version number
(as 4 digits) if libtommath is built into
Tcl, 0 otherwise."
version\
" Returns the Tcl version, same as
${$B}info tclversion${$N}."
zlib\
" Returns the zlib version number (as 4 digits)
if zlib is built into Tcl, 0 otherwise."
}
@values -min 0 -max 0
} "@doc -name Manpage: -url [manpage_tcl buildinfo]"\
{@examples -help {
These show the use of ::tcl::build-info.
${[punk::args::tclcore::argdoc::example {
::tcl::build-info
→ 9.0.2+af16c07b81655fabde8028374161ad54b84ef9956843c63f49976b4ef601b611.gcc-1204
::tcl::build-info commit
→ af16c07b81655fabde8028374161ad54b84ef9956843c63f49976b4ef601b611
::tcl::build-info compiler
→ gcc-1204
::tcl::build-info gcc
→ 1204
::tcl::build-info version
→ 9.0
::tcl::build-info patchlevel
→ 9.0.2
}]}
}
}]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list {
@id -id ::exec
@cmd -name "Builtin: exec"\
@ -2601,7 +2721,34 @@ tcl::namespace::eval punk::args::tclcore {
first -type indexexpression
last -type indexexpression
value -type any -optional 1 -multiple 1
} "@doc -name Manpage: -url [manpage_tcl ledit]"
} "@doc -name Manpage: -url [manpage_tcl ledit]"\
{@examples -help {
Prepend to a list.
${[punk::args::tclcore::argdoc::example {
set lst {c d e f g}
-> c d e f g
ledit lst -1 -1 a b
-> a b c d e f g
}]}
Append to the list.
${[punk::args::tclcore::argdoc::example {
ledit lst end+1 end+1 h i
-> a b c d e f g h i
}]}
Delete the third and fourth elements.
${[punk::args::tclcore::argdoc::example {
ledit lst 2 3
-> a b e f g h i
}]}
Replace two elements with three.
${[punk::args::tclcore::argdoc::example {
ledit lst 2 3 x y z
-> a b x y z g h i
set lst
-> a b x y z g h i
}]}
}
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
@ -3569,6 +3716,240 @@ tcl::namespace::eval punk::args::tclcore {
} "@doc -name Manpage: -url [manpage_tcl set]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::socket
@cmd -name "builtin: socket"\
-summary\
"Open a TCP network connection."\
-help\
"This command opens a network socket and returns a channel identifier that
may be used in future invocations of commands like ${$B}read${$N}, ${$B}puts${$N} and ${$B}flush${$N}.
At present only the TCP network protocol is supported over IPv4 and IPv6;
future releases may include support for additional protocols. The ${$B}socket${$N}
command may be used to open either the client or server side of a
connection, depending on whether the ${$B}-server${$N} switch is specified.
Note that the default encoding for all sockets is the system encoding, as
returned by ${$B}encoding${$N} system. Most of the time, you will need to use chan
configure to alter this to something else, such as utf-8 (ideal for
communicating with other Tcl processes) or iso8859-1 (useful for many
network protocols, especially the older ones).
${$B}CLIENT SOCKETS${$N}
If the -server option is not specified, then the client side of a connection is opened
and the command returns a channel identifier that can be used for both reading and
writing. Port and host specify a port to connect to; there must be a server accepting
connections on this port. Port is an integer port number (or service name, where
supported and understood by the host operating system) and host is either a domain-style
name such as www.tcl.tk or a numerical IPv4 or IPv6 address such as 127.0.0.1 or
2001:DB8::1. Use localhost to refer to the host on which the command is invoked.
${$B}SERVER SOCKETS${$N}
If the -server option is specified then the new socket will be a server that listens on
the given port (either an integer or a service name, where supported and understood by
the host operating system; if port is zero, the operating system will allocate a free
port to the server socket which may be discovered by using chan configure to read the
-sockname option). If the host supports both, IPv4 and IPv6, the socket will listen on
both address families. Tcl will automatically accept connections to the given port. For
each connection Tcl will create a new channel that may be used to communicate with the
client. Tcl then invokes command (properly a command prefix list, see the EXAMPLES below)
with three additional arguments: the name of the new channel, the address, in network
address notation, of the client's host, and the client's port number.
Server channels cannot be used for input or output; their sole use is to accept new
client connections. The channels created for each incoming client connection are opened
for input and output. Closing the server channel shuts down the server so that no new
connections will be accepted; however, existing connections will be unaffected.
Server sockets depend on the Tcl event mechanism to find out when new connections are
opened. If the application does not enter the event loop, for example by invoking the
vwait command or calling the C procedure Tcl_DoOneEvent, then no connections will be
accepted.
If port is specified as zero, the operating system will allocate an unused port for use
as a server socket. The port number actually allocated may be retrieved from the created
server socket using the chan configure command to retrieve the -sockname option as
described below.
${$B}CONFIGURATION OPTIONS${$N}
The chan configure command can be used to query several readonly configuration options
for socket channels or in some cases to set alternative properties on socket channels:
-error
This option gets the current error status of the given socket. This is useful
when you need to determine if an asynchronous connect operation succeeded. If
there was an error, the error message is returned. If there was no error, an
empty string is returned.
Note that the error status is reset by the read operation; this mimics the
underlying getsockopt(SO_ERROR) call.
-sockname
For client sockets (including the channels that get created when a client
connects to a server socket) this option returns a list of three elements,
the address, the host name and the port number for the socket. If the host
name cannot be computed, the second element is identical to the address, the
first element of the list.
For server sockets this option returns a list of a multiple of three elements
each group of which have the same meaning as described above. The list contains
more than one group when the server socket was created without -myaddr or with
the argument to -myaddr being a domain name that resolves multiple IP addresses
that are local to the invoking host.
-peername
This option is not supported by server sockets. For client and accepted sockets,
this option returns a list of three elements; these are the address, the host name
and the port to which the peer socket is connected or bound. If the host name
cannot be computed, the second element of the list is identical to the address,
its first element.
-connecting
This option is not supported by server sockets. For client sockets, this option
returns 1 if an asynchronous connect is still in progress, 0 otherwise.
-keepalive
This option sets or queries the TCP keepalive option on the socket as 1 if
keepalive is turned on, 0 otherwise.
-nodelay
This option sets or queries the TCP nodelay option on the socket as 1 if nodelay
is turned on, 0 otherwise."
@form -form client
@leaders -min 0 -max 0
@opts
-myaddr -type string -typesynopsis ${$I}addr${$NI} -help\
"${$I}Addr${$NI} gives the domain-style name or numerical IP address of the client-side
network interface to use for the connection. This option may be useful if
the client machine has multiple network interfaces. If the option is omitted
then the client-side interface will be chosen by the system software."
-myport -type string -typesynopsis ${$I}port${$NI} -help\
"${$I}Port${$NI} specifies an integer port number (or service name, where supported and
understood by the host operating system) to use for the client's side of the
connection. If this option is omitted, the client's port number will be
chosen at random by the system software."
-async -type none -help\
"This option will cause the client socket to be connected asynchronously. This means
that the socket will be created immediately but may not yet be connected to the
server, when the call to ${$B}socket${$N} returns.
When a gets or flush is done on the socket before the connection attempt succeeds
or fails, if the socket is in blocking mode, the operation will wait until the
connection is completed or fails. If the socket is in nonblocking mode and a gets
or flush is done on the socket before the connection attempt succeeds or fails, the
operation returns immediately and fblocked on the socket returns 1. Synchronous
client sockets may be switched (after they have connected) to operating in
asynchronous mode using:
chan configure chan -blocking 0
See the ${$B}chan configure${$N} command for more details.
The Tcl event loop should be running while an asynchronous connection is in progress,
because it may have to do several connection attempts in the background. Running the
event loop also allows you to set up a writable channel event on the socket to get
notified when the asynchronous connection has succeeded or failed. See the vwait and
the chan commands for more details on the event loop and channel events.
The ${$B}chan configure${$N} option ${$B}-connecting${N} may be used to check if the connect is still
running. To verify a successful connect, the option ${$B}-error${N} may be checked when
${$B}-connecting${$N} returned 0.
Operation without the event queue requires at the moment calls to ${$B}chan configure${$N} to
advance the internal state machine."
@values -min 2 -max 2
host -type string
port -type string
@form -form server
@leaders -min 0 -max 0
@opts
-server -type list -typesynopsis ${$I}command${$NI}
-myaddr -type string -typesynopsis ${$I}addr${$NI} -help\
"Addr gives the domain-style name or numerical IP address of the server-side
network interface to use for the connection. This option may be useful if
the server machine has multiple network interfaces. If the option is
omitted then the server socket is bound to the wildcard address so that it
can accept connections from any interface. If addr is a domain name that
resolves to multiple IP addresses that are available on the local machine,
the socket will listen on all of them."
-reuseaddr -type boolean -help\
"Tells the kernel whether to reuse the local address if there is no socket
actively listening on it. This is the default on Windows."
-reuseport -type boolean -help\
"Tells the kernel whether to allow the binding of multiple sockets to the
same address and port."
@values -min 1 -max 1
port -type string -help\
"port number or service name"
} "@doc -name Manpage: -url [manpage_tcl socket]"\
{@examples -help {
Here is a very simple time server:
${[punk::args::tclcore::argdoc::example {
proc Server {startTime channel clientaddr clientport} {
puts "Connection from $clientaddr registered"
set now [clock seconds]
puts $channel [clock format $now]
puts $channel "[expr {$now - $startTime}] since start"
close $channel
}
socket -server [list Server [clock seconds]] 9900
vwait forever}]}
And here is the corresponding client to talk to the server and extract some information:
${[punk::args::tclcore::argdoc::example {
set server localhost
set sockChan [socket $server 9900]
gets $sockChan line1
gets $sockChan line2
close $sockChan
puts "The time on $server is $line1"
puts "That is [lindex $line2 0]s since the server started" }]}
}}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::source
@cmd -name "builtin: source"\
-summary\
"Evaluate a file or resource as a Tcl script."\
-help\
"This command takes the contents of the specified file or resource and passes
it to the Tcl interpreter as a text script. The return value from ${$B}source${$N} is the
return value of the last command executed in the script. If an error occurs in
evaluating the contents of the script then the ${$B}source${$N} command will return that
error. If a return command is invoked from within the script then the remainder
of the file will be skipped and the ${$B}source${$N} command will return normally with
the result from the return command.
The end-of-file character for files is “\\32” (^Z) for all platforms. The source
command will read files up to this character. This restriction does not exist
for the read or gets commands, allowing for files containing code and data
segments (scripted documents). If you require a “^Z” in code for string
comparison, you can use “\\x1A”, which will be safely substituted by the Tcl
interpreter into “^Z”.
A leading BOM (Byte order mark) contained in the file is ignored for unicode
encodings (utf-8, utf-16, ucs-2).
The ${$B}-encoding${$N} option is used to specify the encoding of the data stored in
${$I}fileName${$NI}. When the ${$B}-encoding option${N} is omitted, the utf-8 encoding is assumed."
@leaders -min 0 -max 0
@opts
-encoding -type string -default utf-8 -typesynopsis ${$I}encodingName${$NI}
fileName
} "@doc -name Manpage: -url [manpage_tcl source]"\
{@examples -help {
Run the script in the file ${B}foo.tcl${$N} and then the script in ${$B}bar.tcl${$N}:
${[punk::args::tclcore::argdoc::example {
source foo.tcl
source bar.tcl }]}
Alternatively:
${[punk::args::tclcore::argdoc::example {
foreach scriptFile {foo.tcl bar.tcl} {
source $scriptFile
}}]}
}}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@ -4505,6 +4886,131 @@ tcl::namespace::eval punk::args::tclcore {
} "@doc -name Manpage: -url [manpage_tcl trace]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
namespace eval argdoc {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::try
@cmd -name "builtin: try"\
-summary\
"Trap and process errors and exceptions"\
-help\
"This command executes the script body and, depending on what the outcome of
that script is (normal exit, error, or some other exceptional result), runs
a handler script to deal with the case. Once that has all happened, if the
finally clause is present, the script it includes will be run and the result
of the handler (or the body if no handler matched) is allowed to continue to
propagate. Note that the finally clause is processed even if an error occurs
and irrespective of which, if any, handler is used.
The handler clauses are each expressed as several words, and must have one of
the following forms:
${$B}on${$N} code variableList script
This clause matches if the evaluation of body completed with the exception
code ${$I}code${$NI}. The code may be expressed as an integer or one of
the following literal words: ok, error, return, break, or continue. Those
literals correspond to the integers 0 through 4 respectively.
${$B}trap${$N} pattern variableList script
This clause matches if the evaluation of body resulted in an error and the
prefix of the -errorcode from the interpreter's status dictionary is equal
to the pattern. The number of prefix words taken from the -errorcode is
equal to the list-length of pattern, and inter-word spaces are normalized
in both the -errorcode and pattern before comparison.
The variableList word in each handler is always interpreted as a list of
variable names. If the first word of the list is present and non-empty, it
names a variable into which the result of the evaluation of body (from the main
try) will be placed; this will contain the human-readable form of any errors.
If the second word of the list is present and non-empty, it names a variable
into which the options dictionary of the interpreter at the moment of
completion of execution of body will be placed.
The script word of each handler is also always interpreted the same: as a Tcl
script to evaluate if the clause is matched. If script is a literal “-” and the
handler is not the last one, the script of the following handler is invoked
instead (just like with the switch command).
Note that handler clauses are matched against in order, and that the first
matching one is always selected. At most one handler clause will selected. As a
consequence, an on error will mask any subsequent trap in the try. Also note
that on error is equivalent to trap {}.
If an exception (i.e. any non-ok result) occurs during the evaluation of either
the handler or the finally clause, the original exception's status dictionary
will be added to the new exception's status dictionary under the -during key."
@leaders -min 0 -max 0
@values -min 1 -max -1
body -type script
# handler for multiple on and/or trap clauses
#This works,but is not ideal. Does not extend to more complex cases.
#we would like to be able to define multiple handler clauses with possibly different arity,
#and display properly distinguished synopses and help (including for example -choices for code type)
#Each type of handler must be able to be interleaved arbitrarily.
#we can't define a separate on_handler and try_handler as it stands, because positionality would
#force all on_handlers to be together and all try_handlers to be together, and it would force
#one type of handler to be listed always before or always after the other.
handler -optional 1 -multiple 1 -type {literal(on)|literal(trap) string list string}\
-typesynopsis {"" code|pattern variableList script}
#todo?
#JJJJ
#a way to define a compound type?
#handler -optional 1 -multiple 1 -type {<on_handler>|<try_handler>}
##<on_handler> -type {literal(on) <code> <variableList> <script>}
##<code> -type int -choices {0|ok 1|error 2|return 3|break 4|continue} -choicelabels {...}
#..
##<try_handler> -type {literal(trap) <pattern> <variableList> <script>}
##<pattern> -type list
#consider also RPN for compound type definitions
##<mytype1> -type {{int double OR}}
##<mytype2> -type {{stringstartswith a stringendswith z AND int OR}}
finally -optional 1 -optional 1 -type {literal(finally) script}
} "@doc -name Manpage: -url [manpage_tcl try]"\
{@examples -help {
Ensure that a file is closed no matter what:
${[punk::args::tclcore::argdoc::example {
set f [open /some/file/name a]
try {
puts $f "some message"
# ...
} finally {
close $f
}
}]}
Handle different reasons for a file to not be openable for reading:
${[punk::args::tclcore::argdoc::example {
try {
set f [open /some/file/name r]
} trap {POSIX EISDIR} {} {
puts "failed to open /some/file/name: it's a directory"
} trap {POSIX ENOENT} {} {
puts "failed to open /some/file/name: it doesn't exist"
}
}]}
Proc to read a file in utf-8 encoding and return its contents.
The file is closed in success and error case by the finally clause.
It is allowed to call return within the try block. Remark that with
tcl 9, the read command may also throw utf-8 conversion errors:
${[punk::args::tclcore::argdoc::example {
proc readfile {filename} {
set f [open $filename r]
try {
fconfigure $f -encoding utf-8 -profile strict
return [read $f]
} finally {
close $f
}
}
}]}
}
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::variable
@ -4564,7 +5070,239 @@ tcl::namespace::eval punk::args::tclcore {
} "@doc -name Manpage: -url [manpage_tcl variable]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::vwait
@cmd -name "builtin: ::vwait"\
-summary\
"Process events until a variable is written."\
-help\
"This command enters the Tcl event loop to process events, blocking the application
if no events are ready. It continues processing events until some event handler sets
the value of the global variable varName. Once varName has been set, the vwait
command will return as soon as the event handler that modified varName completes.
The varName argument is always interpreted as a variable name with respect to the
global namespace, but can refer to any namespace's variables if the fully-qualified
name is given.
In the second more complex command form options allow for finer control of the wait
operation and to deal with multiple event sources.
The result returned by vwait is for the simple form an empty string. If the -timeout
option is specified, the result is the number of milliseconds remaining when the wait
condition has been met, or -1 if the wait operation timed out.
If the -extended option is specified, the result is made up of a Tcl list with an
even number of elements. Odd elements take the values readable, timeleft, variable,
and writable. Even elements are the corresponding variable and channel names or the
remaining number of milliseconds. The list is ordered by the occurrences of the
event(s) with the exception of timeleft which always comes last.
In some cases the vwait command may not return immediately after varName et.al. is set.
This happens if the event handler that sets varName does not complete immediately. For
example, if an event handler sets varName and then itself calls vwait to wait for a
different variable, then it may not return for a long time. During this time the
top-level vwait is blocked waiting for the event handler to complete, so it cannot
return either. (See the NESTED VWAITS BY EXAMPLE below.)
To be clear, multiple vwait calls will nest and will not happen in parallel. The
outermost call to vwait will not return until all the inner ones do. It is recommended
that code should never nest vwait calls (by avoiding putting them in event callbacks)
but when that is not possible, care should be taken to add interlock variables to the
code to prevent all reentrant calls to vwait that are not strictly necessary. Be aware
that the synchronous modes of operation of some Tcl packages (e.g., http) use vwait
internally; if using the event loop, it is best to use the asynchronous callback-based
modes of operation of those packages where available."
@form -form basic
@leaders -min 0 -max 0
@opts -min 0 -max 0
@values -min 1 -max 1
varName -type string
@form -form complex
@leaders -min 0 -max 0
@opts
-all -type none -help\
"All conditions for the wait operation must be met to complete the wait operation.
Otherwise (the default) the first event completes the wait"
-extended -type none -help\
"An extended result in list form is returned, see above for explanation."
-nofileevents -type none -help\
"File events are not handled in the wait operation."
-noidleevents -type none -help\
"Idle handlers are not invoked during the wait operation."
-notimerevents -type none -help\
"Timer handlers are not serviced during the wait operation."
-nowindowevents -type none -help\
"Events of the windowing system are not handled during the wait operation."
-readable -type string -typesynopsis ${$I}channel${$NI} -help\
"${$I}Channel${$NI} must name a Tcl channel open for reading. If ${$I}channel${$NI} is or becomes
readable the wait operation completes."
-timeout -type integer -typesynopsis ${$I}milliseconds${$NI} -help\
"The wait operation is constrained to ${$I}milliseconds${$NI}."
-variable -type string -typesynopsis ${$I}varName${$NI} -help\
"${$I}VarName${$NI} must be the name of a global variable. Writing or unsetting this variable
completes the wait operation."
-writable -type string -typesynopsis ${$I}channel${$NI} -help\
"${$I}Channel${$NI} must name a Tcl channel open for writing. If ${$I}channel${$NI} is or becomes
writable the wait operation completes."
-- -type none -help\
"Marks the end of options. All following arguments are handled as variable names."
@values -min 0 -max -1
varName -type string -multiple 1 -optional 1
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl vwait]"\
{@examples -help {
Run the event-loop continually until some event calls exit. (You can use any variable not mentioned elsewhere,
but the name forever reminds you at a glance of the intent.)
${[punk::args::tclcore::argdoc::example {
vwait forever
}]}
Wait five seconds for a connection to a server socket, otherwise close the socket and continue running the script:
${[punk::args::tclcore::argdoc::example {
# Initialise the state
after 5000 set state timeout
set server [socket -server accept 12345]
proc accept {args} {
global state connectionInfo
set state accepted
set connectionInfo $args
}
# Wait for something to happen
vwait state
# Clean up events that could have happened
close $server
after cancel set state timeout
# Do something based on how the vwait finished...
switch $state {
timeout {
puts "no connection on port 12345"
}
accepted {
puts "connection: $connectionInfo"
puts [lindex $connectionInfo 0] "Hello there!"
}
}
}]}
A command that will wait for some time delay by waiting for a namespace variable to be set. Includes an interlock
to prevent nested waits.
${[punk::args::tclcore::argdoc::example {
namespace eval example {
variable v done
proc wait {delay} {
variable v
if {$v ne "waiting"} {
set v waiting
after $delay [namespace code {set v done}]
vwait [namespace which -variable v]
}
return $v
}
}
}]}
${$B}NESTED VWAITS BY EXAMPLE${$N}
This example demonstrates what can happen when the vwait command is nested. The script will never finish because
the waiting for the a variable never finishes; that vwait command is still waiting for a script scheduled with
after to complete, which just happens to be running an inner vwait (for b) even though the event that the outer
vwait was waiting for (the setting of a) has occurred.
${[punk::args::tclcore::argdoc::example {
after 500 {
puts "waiting for b"
vwait b
puts "b was set"
}
after 1000 {
puts "setting a"
set a 10
}
puts "waiting for a"
vwait a
puts "a was set"
puts "setting b"
set b 42
}]}
If you run the above code, you get this output:
${[punk::args::tclcore::argdoc::example {
waiting for a
waiting for b
setting a
}]}
The script will never print “a was set” until after it has printed “b was set” because of the nesting of vwait
commands, and yet b will not be set until after the outer vwait returns, so the script has deadlocked. The only
ways to avoid this are to either structure the overall program in continuation-passing style or to use coroutine
to make the continuations implicit. The first of these options would be written as:
${[punk::args::tclcore::argdoc::example {
after 500 {
puts "waiting for b"
trace add variable b write {apply {args {
global a b
trace remove variable ::b write \
[lrange [info level 0] 0 1]
puts "b was set"
set ::done ok
}}}
}
after 1000 {
puts "setting a"
set a 10
}
puts "waiting for a"
trace add variable a write {apply {args {
global a b
trace remove variable a write [lrange [info level 0] 0 1]
puts "a was set"
puts "setting b"
set b 42
}}}
vwait done
}]}
The second option, with coroutine and some helper procedures, is done like this:
${[punk::args::tclcore::argdoc::example {
# A coroutine-based wait-for-variable command
proc waitvar globalVar {
trace add variable ::$globalVar write \
[list apply {{v c args} {
trace remove variable $v write \
[lrange [info level 0] 0 3]
after 0 $c
}} ::$globalVar [info coroutine]]
yield
}
# A coroutine-based wait-for-some-time command
proc waittime ms {
after $ms [info coroutine]
yield
}
coroutine task-1 eval {
puts "waiting for a"
waitvar a
puts "a was set"
puts "setting b"
set b 42
}
coroutine task-2 eval {
waittime 500
puts "waiting for b"
waitvar b
puts "b was set"
set done ok
}
coroutine task-3 eval {
waittime 1000
puts "setting a"
set a 10
}
vwait done
}]}
}}
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
namespace eval argdoc {
@ -4647,7 +5385,7 @@ tcl::namespace::eval punk::args::tclcore {
${$B}uplevel #0${$N} evaluates a script at top-level in the outermost namespace (the
global namespace).}
@leaders -min 0 -max 1
level -type int|stringprefix(#) -optional 1 -default 1
level -type int|stringstartswith(#) -optional 1 -default 1
@values -min 1 -max -1
arg -type string -optional 0 -multiple 1
} "@doc -name Manpage: -url [manpage_tcl uplevel]" ]
@ -4700,16 +5438,16 @@ tcl::namespace::eval punk::args::tclcore {
is possible to retarget an upvar variable by executing another ${$B}upvar${$N} command.}
@leaders -min 0 -max 1 -takewhenargsmodulo 2
#consider -takewhenargsmodulo 2 ?? incompatible with various mixed @opts/@values configurations
#level -type int|stringprefix(#) -optional 1 -default 1
#level -type int|stringstartswith(#) -optional 1 -default 1
# stringregexp(^#[0-9]$)
# stringsuffix(xxx)
#todo - review
#this leader is greedy - i.e if the type matches it will take it.
#this is at odds with the way Tcl parses upvar args - it seems to look at the number of total args
#and will not assign a first value that passes int|stringprefix(#) to 'level' if there is an even number of args in total
#and will not assign a first value that passes int|stringstartswith(#) to 'level' if there is an even number of args in total
#e.g tcl will accept: upvar #1 blah #2 etc
level -type int|stringprefix(#) -optional 1 -default 1
#hence the need for -takewhenargsmodulo 2
level -type int|stringstartswith(#) -optional 1 -default 1
@values -min 2 -max -1
varmapping -type {string string} -typesynopsis {${$I}otherVar${$NI} ${$I}myVar${$NI}} -optional 0 -multiple 1
} "@doc -name Manpage: -url [manpage_tcl upvar]" ]
@ -4882,7 +5620,7 @@ tcl::namespace::eval punk::args::tclcore {
This read-write option is used by decompressing channels to control the
maximum number of bytes ahead to read from the underlying data source.
See below for more information."
@leaders -min 1 -max 1
@leaders -min 2 -max 2
# -- --- --- --- --- --- --- --- --- --- ---
mode -type string -choicecolumns 2 -choices {compress decompress deflate gunzip gzip inflate} -choicelabels {
compress\
@ -4910,6 +5648,7 @@ tcl::namespace::eval punk::args::tclcore {
transformation that reads raw compressed
data from channel, which must be readable."
}
channel -type string
@opts
-dictionary -type dict -typesynopsis ${$I}binData${$NI} -help\
"Sets the compression dictionary to use when working with compressing or
@ -5062,7 +5801,30 @@ tcl::namespace::eval punk::args::tclcore {
-choicelabels {${$CHOICELABELS}}\
-choiceinfo {${$CHOICEINFO}}
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"\
{@examples -help {
To compress a Tcl string, it should be first converted to a particular charset encoding since the zlib
command always operates on binary strings.
${[punk::args::tclcore::argdoc::example {
set binData [encoding convertto utf-8 $string]
set compData [zlib compress $binData]
}]}
When converting back, it is also important to reverse the charset encoding:
${[punk::args::tclcore::argdoc::example {
set binData [zlib decompress $compData]
set string [encoding convertfrom utf-8 $binData]
}]}
The compression operation from above can also be done with streams, which is especially helpful when you
want to accumulate the data by stages:
${[punk::args::tclcore::argdoc::example {
set strm [zlib stream compress]
$strm put [encoding convertto utf-8 $string]
# ...
$strm finalize
set compData [$strm get]
$strm close
}]}
}}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---

622
src/modules/punk/args/tkcore-999999.0a1.0.tm
Unescape View File

@ -0,0 +1,622 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# 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) 2025
#
# @@ Meta Begin
# Application punk::args::tkcore 999999.0a1.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::args::tkcore 0 999999.0a1.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require punk::args::tkcore]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::args::tkcore
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::args::tkcore
#[list_begin itemized]
package require Tcl 8.6-
package require punk::args
package require punk::ansi
package require textblock
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package {punk::args}]
#[item] [package {textblock}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
tcl::namespace::eval punk::args::tkcore {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection {Namespace punk::args::tkcore}]
#[para] Core API functions for punk::args::tkcore
#[list_begin definitions]
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
set A_WARN \x1b\[7m
set A_RST \x1b\[0m
variable manbase
variable manbase_ext
set patch [info patchlevel]
lassign [split $patch .] major
if {$major < 9} {
set manbase "https://tcl.tk/man/tcl/TkCmd"
set manbase_ext .htm
} else {
set manbase "https://tcl.tk/man/tcl9.0/TkCmd"
set manbase_ext .html
}
proc manpage {cmd} {
variable manbase
variable manbase_ext
return ${manbase}/${cmd}${manbase_ext}
}
variable PUNKARGS
namespace eval argdoc {
tcl::namespace::import ::punk::ansi::a+
tcl::namespace::import ::punk::args::tkcore::manpage
# -- --- --- --- ---
#non colour SGR codes
# we can use these directly via ${$I} etc without marking a definition with @dynamic
#This is because they don't need to change when colour switched on and off.
set I [a+ italic]
set NI [a+ noitalic]
set B [a+ bold]
set N [a+ normal]
# -- --- --- --- ---
proc example {str} {
set str [string trimleft $str \n]
set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Web-gray bold white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]]
set result [textblock::bookend_lines $block [a] "[a defaultbg] [a]"]
#puts $result
return $result
}
}
namespace eval argdoc {
lappend PUNKARGS [list {
@id -id "(default)::punk::args::tkcore::common"
} "@doc -name Manpage: -url [manpage index]" ]
#list all tk_standardoptions
#use punk::args::resolved_spec
#{${[punk::args::resolved_def -types opts (default)::punk::args::tkcore::tk_standardoptions -disabledforeground -font ...]}}
::punk::args::define {
@id -id "(default)::punk::args::tkcore::tk_standardoptions"
-activebackground -type colour -help\
"Specifies background color to use when drawing active elements. An element (a widget or portion of a widget)
is active if the mouse cursor is positioned over the element and pressing a mouse button will cause some
action to occur. If strict Motif compliance has been requested by setting the tk_strictMotif variable, this
option will normally be ignored; the normal background color will be used instead. For some elements on
Windows and Macintosh systems, the active color will only be used while mouse button 1 is pressed over the
element."
-activeborderwidth -type tk_screen_units -help\
"Specifies a non-negative value indicating the width of the 3-D border drawn around active elements. See above
for definition of active elements. The value may have any of the forms acceptable to Tk_GetPixels. This option
is typically only available in widgets displaying more than one element at a time (e.g. menus but not buttons)."
-activeforeground -type colour -help\
"Specifies foreground color to use when drawing active elements. See above for definition of active elements."
-activerelief -type string -choicecolumns 6 -choices {raised sunken flat ridge solid groove} -help\
"Specifies the 3-D effect desired for the active item of the widget. See the -relief option for details."
-anchor -type string -choicecolumns 9 -choices {n ne e se s sw w nw center} -help\
"Specifies how the information in a widget (e.g. text or a bitmap) is to be displayed in the widget.
For example, ${$B}nw${$N} means display the information such that its top-left corner is at the top-left corner of the widget."
-background|-bg -type colour -help\
"Specifies the normal background color to use when displaying the widget."
-bitmap -type bmp -help\
"Specifies a bitmap to display in the widget, in any of the forms acceptable to Tk_GetBitmap. The exact
way in which the bitmap is displayed may be affected by other options such as -anchor or -justify.
Typically, if this option is specified then it overrides other options that specify a textual value to
display in the widget but this is controlled by the ${$B}-compound${$N} option; the -bitmap option may be reset to
an empty string to re-enable a text display. In widgets that support both -bitmap and -image options,
-image will usually override -bitmap."
-borderwidth|-bd -type tk_screen_units -help\
"Specifies a non-negative value indicating the width of the 3-D border to draw around the outside of the
widget (if such a border is being drawn; the -relief option typically determines this). The value may
also be used when drawing 3-D effects in the interior of the widget. The value may have any of the
forms acceptable to Tk_GetPixels."
#todo - something better for large -choices lists
#list of cursors is large, not obtainable dynamically, and has some that are platform specific.
-cursor -type string -help\
""
-compound -type string -choicecolumns 6 -choices {none bottom top left right center} -help\
"Specifies if the widget should display text and bitmaps/images at the same time, and if so, where the
bitmap/image should be placed relative to the text. Must be one of the values none, bottom, top, left,
right, or center. For example, the (default) value none specifies that the bitmap or image should
(if defined) be displayed instead of the text, the value ${$B}left${$N} specifies that the bitmap or image should
be displayed to the left of the text, and the value ${$B}center${$N} specifies that the bitmap or image should be
displayed on top of the text."
-disabledforeground -type colour|literal() -help\
"Specifies foreground color to use when drawing a disabled element. If the option is specified
as an empty string (which is typically the case on monochrome displays), disabled elements
are drawn with the normal foreground color but they are dimmed by drawing them with a
stippled fill pattern."
-exportselection -type boolean -help\
"Specifies whether or not a selection in the widget should also be the X selection. The value may have any of the
forms accepted by Tcl_GetBoolean, such as true, false, 0, 1, yes, or no. If the selection is exported, then
selecting in the widget deselects the current X selection, selecting outside the widget deselects any widget
selection, and the widget will respond to selection retrieval requests when it has a selection. The default is
usually for widgets to export selections."
-font -type tk_font -help\
"Specifies the font to use when drawing text inside the widget. The value may have any of the
forms described in the font manual page under FONT DESCRIPTION."
-foreground|-fg -type colour -help\
"Specifies the normal foreground color to use when displaying the widget."
-highlightbackground -type colour -help\
"Specifies the color to display in the traversal highlight region when the widget does not have the input focus."
-highlightcolor -type colour -help\
"Specifies the color to use for the traversal highlight rectangle that is drawn around the widget when it has the
input focus."
-highlightthicknes -type tk_screen_units -help\
"Specifies a non-negative value indicating the width of the highlight rectangle to draw around the outside of the
widget when it has the input focus. The value may have any of the forms acceptable to Tk_GetPixels. If the
value is zero, no focus highlight is drawn around the widget."
-image -type string -help\
"Specifies an image to display in the widget, which must have been created with the image create command.
Typically, if the -image option is specified then it overrides other options that specify a bitmap or textual
value to display in the widget, though this is controlled by the -compound option; the -image option may be
reset to an empty string to re-enable a bitmap or text display."
-insertbackground -type colour -help\
"Specifies the color to use as background in the area covered by the insertion cursor. This color will normally
override either the normal background for the widget (or the selection background if the insertion cursor
happens to fall in the selection)."
-insertborderwidth -type tk_screen_units -help\
"Specifies a non-negative value indicating the width of the 3-D border to draw around the insertion cursor.
The value may have any of the forms acceptable to Tk_GetPixels."
-insertofftime -type integer -typesynopsis {${$I}ms${$NI}} -range {0 ""} -help\
"Specifies a non-negative integer value indicating the number of milliseconds the insertion cursor should remain
“off” in each blink cycle. If this option is zero then the cursor does not blink: it is on all the time."
-insertontime -type integer -typesynopsis {${$I}ms${$NI}} -range {0 ""} -help\
"Specifies a non-negative integer value indicating the number of milliseconds the insertion cursor should remain
“on” in each blink cycle."
-insertwidth -type tk_screen_units -help\
"Specifies a non-negative value indicating the total width of the insertion cursor. The value may have any of the
forms acceptable to Tk_GetPixels. If a border has been specified for the insertion cursor (using the
-insertborderwidth option), the border will be drawn inside the width specified by the -insertwidth option."
-jump -type boolean -help\
"For widgets with a slider that can be dragged to adjust a value, such as scrollbars, this option determines when
notifications are made about changes in the value. The option's value must be a boolean of the form accepted by
Tcl_GetBoolean. If the value is false, updates are made continuously as the slider is dragged. If the value is
true, updates are delayed until the mouse button is released to end the drag; at that point a single
notification is made (the value “jumps” rather than changing smoothly)."
-justify -type string -choicecolumns 3 -choices {left center right} -help\
"When there are multiple lines of text displayed in a widget, this option determines how the lines line up with
each other. Must be one of left, center, or right. Left means that the lines' left edges all line up, center
means that the lines' centers are aligned, and right means that the lines' right edges line up."
-orient -type string -choiceprefix 1 -choicecolumns 2 -choices {horizontal vertical} -help\
"For widgets that can lay themselves out with either a horizontal or vertical orientation, such as scrollbars,
this option specifies which orientation should be used. Must be either horizontal or vertical or an
abbreviation of one of these."
-padx -type tk_screen_units -help\
"Specifies a non-negative value indicating how much extra space to request for the widget in the X-direction.
The value may have any of the forms acceptable to Tk_GetPixels. When computing how large a window it needs,
the widget will add this amount to the width it would normally need (as determined by the width of the things
displayed in the widget); if the geometry manager can satisfy this request, the widget will end up with extra
internal space to the left and/or right of what it displays inside. Most widgets only use this option for
padding text: if they are displaying a bitmap or image, then they usually ignore padding options."
-pady -type tk_screen_units -help\
"Specifies a non-negative value indicating how much extra space to request for the widget in the Y-direction.
The value may have any of the forms acceptable to Tk_GetPixels. When computing how large a window it needs,
the widget will add this amount to the height it would normally need (as determined by the height of the things
displayed in the widget); if the geometry manager can satisfy this request, the widget will end up with extra
internal space above and/or below what it displays inside. Most widgets only use this option for padding text:
if they are displaying a bitmap or image, then they usually ignore padding options."
-placeholder -type string -help\
"Specifies a help text string to display if no text is otherwise displayed, that is when the widget is empty.
The placeholder text is displayed using the values of the -font and -justify options."
-placeholderforeground -type colour -help\
"Specifies the foreground color to use when the placeholder text is displayed.
The default color is platform-specific."
-relief -type string -choicecolumns 6 -choices {raised sunken flat ridge solid groove} -help\
"Specifies the 3-D effect desired for the widget. Acceptable values are raised, sunken, flat, ridge, solid, and
groove. The value indicates how the interior of the widget should appear relative to its exterior; for example,
raised means the interior of the widget should appear to protrude from the screen, relative to the exterior of
the widget."
-repeatdelay -type integer -typesynopsis {${$I}ms${$NI}} -help\
"Specifies the number of milliseconds a button or key must be held down before it begins to auto-repeat. Used,
for example, on the up- and down-arrows in scrollbars."
-repeatinterval -type integer -typesynopsis {${$I}ms${$NI}} -help\
"Used in conjunction with -repeatdelay: once auto-repeat begins, this option determines the number of
milliseconds between auto-repeats."
-selectbackground -type colour -help\
"Specifies the background color to use when displaying selected items."
-selectborderwidth -type tk_screen_units -help\
"Specifies a non-negative value indicating the width of the 3-D border to draw around selected items.
The value may have any of the forms acceptable to Tk_GetPixels."
-selectforeground -type colour -help\
"Specifies the foreground color to use when displaying selected items."
-setgrid -type boolean -help\
"Specifies a boolean value that determines whether this widget controls the resizing grid for its top-level window.
This option is typically used in text widgets, where the information in the widget has a natural size (the size
of a character) and it makes sense for the window's dimensions to be integral numbers of these units. These
natural window sizes form a grid. If the -setgrid option is set to true then the widget will communicate with the
window manager so that when the user interactively resizes the top-level window that contains the widget, the
dimensions of the window will be displayed to the user in grid units and the window size will be constrained to
integral numbers of grid units. See the section GRIDDED GEOMETRY MANAGEMENT in the wm manual entry for more
details."
-takefocus -type literal(0)|literal(1)|literal() -help\
"Determines whether the window accepts the focus during keyboard traversal (e.g., Tab and Shift-Tab). Before
setting the focus to a window, the traversal scripts consult the value of the -takefocus option. A value of 0
means that the window should be skipped entirely during keyboard traversal. 1 means that the window should
receive the input focus as long as it is viewable (it and all of its ancestors are mapped). An empty value for
the option means that the traversal scripts make the decision about whether or not to focus on the window: the
current algorithm is to skip the window if it is disabled, if it has no key bindings, or if it is not viewable.
If the value has any other form, then the traversal scripts take the value, append the name of the window to it
(with a separator space), and evaluate the resulting string as a Tcl script. The script must return 0, 1, or an
empty string: a 0 or 1 value specifies whether the window will receive the input focus, and an empty string
results in the default decision described above. Note that this interpretation of the option is defined entirely
by the Tcl scripts that implement traversal: the widget implementations ignore the option entirely, so you can
change its meaning if you redefine the keyboard traversal scripts."
-text -type string -help\
"Specifies a string to be displayed inside the widget. The way in which the string is displayed depends on the
particular widget and may be determined by other options, such as -anchor or -justify."
-textvariable -type string -help\
"Specifies the name of a global variable. The value of the variable is a text string to be displayed inside the
widget; if the variable value changes then the widget will automatically update itself to reflect the new value.
The way in which the string is displayed in the widget depends on the particular widget and may be determined by
other options, such as -anchor or -justify."
-troughcolor -type colour -help\
"Specifies the color to use for the rectangular trough areas in widgets such as scrollbars and scales. This option
is ignored for scrollbars on Windows (native widget does not recognize this option)."
-underline -type indexexpression -help\
"Specifies the integer index of a character to underline in the widget. This option is used by the default
bindings to implement keyboard traversal for menu buttons and menu entries. 0 corresponds to the first character
of the text displayed in the widget, 1 to the next character, and so on. end corresponds to the last character,
end-1 to the before last character, and so on."
-wraplength -type tk_screen_units -help\
"For widgets that can perform word-wrapping, this option specifies the maximum line length. Lines that would
exceed this length are wrapped onto the next line, so that no line is longer than the specified length. The
value may be specified in any of the standard forms for screen distances. If this value is negative or zero
then no wrapping is done: lines will break only at newline characters in the text."
-xscrollcommand -type list -typesynopsis {${$I}cmdprefix${$NI}} -help\
"Specifies the prefix for a command used to communicate with horizontal scrollbars. When the view in the widget's
window changes (or whenever anything else occurs that could change the display in a scrollbar, such as a change
in the total size of the widget's contents), the widget will generate a Tcl command by concatenating the scroll
command and two numbers. Each of the numbers is a fraction between 0 and 1, which indicates a position in the
document. 0 indicates the beginning of the document, 1 indicates the end, .333 indicates a position one third
the way through the document, and so on. The first fraction indicates the first information in the document
that is visible in the window, and the second fraction indicates the information just after the last portion
that is visible. The command is then passed to the Tcl interpreter for execution. Typically the -xscrollcommand
option consists of the path name of a scrollbar widget followed by “set”, e.g. “.x.scrollbar set”: this will
cause the scrollbar to be updated whenever the view in the window changes. If this option is not specified,
then no command will be executed."
-yscrollcommand -type list -typesynopsis {${$I}cmdprefix${$NI}} -help\
"Specifies the prefix for a command used to communicate with vertical scrollbars. This option is treated in the
same way as the -xscrollcommand option, except that it is used for vertical scrollbars and is provided by
widgets that support vertical scrolling. See the description of -xscrollcommand for details on how this option
is used."
} "@doc -name Manpage: -url [manpage options]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list {
@id -id ::bell
@cmd -name "Tk Builtin: bell"\
-summary\
"Ring a display's bell."\
-help\
"This command rings the bell on the display for ${$I}window${$NI} and returns an empty string.
If the ${$B}-displayof${$N} option is omitted, the display of the application's main window
is used by default. The command uses the current bell-related settings for the
display, which may be modified with programs such as ${$B}xset${$N}.
If ${$B}-nice${$N} is not specified, this command also resets the screen saver for the screen.
Some screen savers will ignore this, but others will reset so that the screen
becomes visible again."
@opts
-displayof -type stringstartswith(.) -typesynopsis window
-nice -type none
@values -min 0 -max 0
} "@doc -name Manpage: -url [manpage bell]" ]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS_aliases {::button ::tk::button}
punk::args::define {
@id -id ::tk::button
@cmd -name "Tk Builtin: tk::button"\
-summary\
"Create and manipulate 'button' action widgets."\
-help\
"The ${$B}button${$N} command creates a new window (given by the ${$I}pathName${$NI} argument) and makes it into a button
widget. Additional options, described above, may be specified on the command line or in the option
database to configure aspects of the button such as its colors, font, text, and initial relief. The
${$B}button${$N} command returns its ${$I}pathName${$NI} argument. At the time this command is invoked, there must not
exist a window named ${$I}pathName${$NI}, but ${$I}pathName${$NI}'s parent must exist.
A button is a widget that displays a textual string, bitmap or image. If text is displayed, it must
all be in a single font, but it can occupy multiple lines on the screen (if it contains newlines or
if wrapping occurs because of the ${$B}-wraplength${$N} option) and one of the characters may optionally be
underlined using the ${$B}-underline${$N} option. It can display itself in either of three different ways,
according to the ${$B}-state${$N} option; it can be made to appear raised, sunken, or flat; and it can be made
to flash. When a user invokes the button (by pressing mouse button 1 with the cursor over the button),
then the Tcl command specified in the ${$B}-command${$N} option is invoked."
@leaders
pathName -type tk_path
@opts -type string -parsekey "" -group "STANDARD OPTIONS" -grouphelp\
""
}\
{${[punk::args::resolved_def -types opts (default)::punk::args::tkcore::tk_standardoptions\
-activebackground\
-activeforeground\
-anchor\
-background|-bg\
-bitmap\
-borderwidth|-bd\
-compound\
-cursor\
-disabledforeground\
-font\
-foreground|-fg\
-highligthbackground\
-highlightcolor\
-highlightthickness\
-image\
-justify\
-padx\
-pady\
-relief\
-takefocus\
-text\
-textvariable\
-underline\
-wraplength\
]}}\
{
@opts -type string -parsekey "" -group "WIDGET-SPECIFIC OPTIONS" -grouphelp\
""
-command -type script -help\
"Specifies a Tcl command to associate with the button. This command is typically invoked when mouse button 1
is released over the button window."
-default -type string -choices {normal active disabled} -help\
"Specifies one of three states for the default ring: normal, active, or disabled. In active state, the button
is drawn with the platform specific appearance for a default button. In normal state, the button is drawn
with the platform specific appearance for a non-default button, leaving enough space to draw the default
button appearance. The normal and active states will result in buttons of the same size. In disabled state,
the button is drawn with the non-default button appearance without leaving space for the default appearance.
The disabled state may result in a smaller button than the active state."
-height -type tk_screen_units -help\
"Specifies a desired height for the button. If an image or bitmap is being displayed in the button then the
value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text.
If this option is not specified, the button's desired height is computed from the size of the image or bitmap
or text being displayed in it."
-overrelief -type string -default "" -choicecolumns 7 -choices {raised sunken flat ridge solid groove ""} -help\
"Specifies an alternative relief for the button, to be used when the mouse cursor is over the widget. This
option can be used to make toolbar buttons, by configuring -relief flat -overrelief raised. If the value of
this option is the empty string, then no alternative relief is used when the mouse cursor is over the button.
The empty string is the default value."
-state -type string -choices {normal active disabled} -help\
"Specifies one of three states for the button: normal, active, or disabled. In normal state the button is
displayed using the ${$B}-foreground${$N} and ${$B}-background${$N} options. The active state is typically used when the pointer
is over the button. In active state the button is displayed using the ${$B}-activeforeground${$N} and ${$B}-activebackground${$N}
options. Disabled state means that the button should be insensitive: the default bindings will refuse to
activate the widget and will ignore mouse button presses. In this state the ${$B}-disabledforeground${$N} and
${$B}-background${$N} options determine how the button is displayed."
-width -type tk_screen_units -help\
"Specifies a desired width for the button. If an image or bitmap is being displayed in the button then the
value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels). For a text button (no image or
with -compound none) then the width specifies how much space in characters to allocate for the text label.
If the width is negative then this specifies a minimum width. If this option is not specified, the button's
desired width is computed from the size of the image or bitmap or text being displayed in it."
} "@doc -name Manpage: -url [manpage bell]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::args::tkcore ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::args::tkcore::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::args::tkcore::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::args::tkcore::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::args::tkcore::system {
#*** !doctools
#[subsection {Namespace punk::args::tkcore::system}]
#[para] Internal functions that are not part of the API
#}
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::args::tkcore {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
variable PUNKARGS
variable PUNKARGS_aliases
lappend PUNKARGS [list {
@id -id "(package)punk::args::tkcore"
@package -name "punk::args::tkcore" -help\
"Package
Description"
}]
namespace eval argdoc {
#namespace for custom argument documentation
proc package_name {} {
return punk::args::tkcore
}
proc about_topics {} {
#info commands results are returned in an arbitrary order (like array keys)
set topic_funs [info commands [namespace current]::get_topic_*]
set about_topics [list]
foreach f $topic_funs {
set tail [namespace tail $f]
lappend about_topics [string range $tail [string length get_topic_] end]
}
#Adjust this function or 'default_topics' if a different order is required
return [lsort $about_topics]
}
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
# get_topic_ functions add more to auto-include in about topics
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr [string trim {
package punk::args::tkcore
punk::args documentation for Tk
} \n]
}
proc get_topic_License {} {
return "MIT"
}
proc get_topic_Version {} {
return "$::punk::args::tkcore::version"
}
proc get_topic_Contributors {} {
set authors {{Julian Noble <julian@precisium.com.au}}
set contributors ""
foreach a $authors {
append contributors $a \n
}
if {[string index $contributors end] eq "\n"} {
set contributors [string range $contributors 0 end-1]
}
return $contributors
}
#proc get_topic_custom-topic {} {
# punk::args::lib::tstr -return string {
# ""
# }
#}
# -------------------------------------------------------------
}
# we re-use the argument definition from punk::args::standard_about and override some items
set overrides [dict create]
dict set overrides @id -id "::punk::args::tkcore::about"
dict set overrides @cmd -name "punk::args::tkcore::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About punk::args::tkcore
}] \n]
dict set overrides topic -choices [list {*}[punk::args::tkcore::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
dict set overrides topic -default [punk::args::tkcore::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *]
lappend PUNKARGS [list $newdef]
proc about {args} {
package require punk::args
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on
set argd [punk::args::parse $args withid ::punk::args::tkcore::about]
lassign [dict values $argd] _leaders opts values _received
punk::args::package::standard_about -package_about_namespace ::punk::args::tkcore::argdoc {*}$opts {*}[dict get $values topic]
}
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===
# -----------------------------------------------------------------------------
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked
# -----------------------------------------------------------------------------
# variable PUNKARGS
# variable PUNKARGS_aliases
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::punk::args::tkcore ::punk::args::tkcore::argdoc
}
# -----------------------------------------------------------------------------
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::args::tkcore [tcl::namespace::eval punk::args::tkcore {
variable pkg punk::args::tkcore
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]

3
src/modules/punk/args/tkcore-buildversion.txt
Unescape View File

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

15
src/modules/punk/console-999999.0a1.0.tm
Unescape View File

@ -612,10 +612,12 @@ namespace eval punk::console {
-terminal -default {stdin stdout} -type list -help\
"terminal (currently list of in/out channels) (todo - object?)"
-expected_ms -default 100 -type integer -help\
-expected_ms -default 300 -type integer -help\
"Expected number of ms for response from terminal.
100ms is usually plenty for a local terminal and a
basic query such as cursor position."
basic query such as cursor position.
However on a busy machine a higher timeout may be
prudent."
@values -min 2 -max 2
query -type string -help\
"ANSI sequence such as \x1b\[?6n which
@ -687,12 +689,14 @@ namespace eval punk::console {
set queuedata($callid) $args
set runningid [lindex $queue 0]
while {$runningid ne $callid} {
#puts stderr "."
vwait ::punk::console::ansi_response_wait
set runningid [lindex $queue 0]
if {$runningid ne $callid} {
set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid)
update ;#REVIEW - probably a bad idea
after 10
set runningid [lindex $queue 0] ;#jn test
}
}
}
@ -779,7 +783,7 @@ namespace eval punk::console {
puts "blank extension $waitvar($callid)"
puts "->[set $waitvar($callid)]<-"
}
puts stderr "get_ansi_response_payload Extending timeout by $extension"
puts stderr "get_ansi_response_payload Extending timeout by $extension for callid:$callid"
after cancel $timeoutid($callid)
set total_elapsed [expr {[clock millis] - $tslaunch($callid)}]
set last_elapsed [expr {[clock millis] - $lastvwait}]
@ -916,7 +920,8 @@ namespace eval punk::console {
unset -nocomplain tslaunch($callid)
dict unset queuedata $callid
lpop queue 0
#lpop queue 0
ledit queue 0 0
if {[llength $queue] > 0} {
set next_callid [lindex $queue 0]
set waitvar($callid) go_ahead
@ -977,7 +982,7 @@ namespace eval punk::console {
set tsnow [clock millis]
set total_elapsed [expr {[set tslaunch($callid)] - $tsnow}]
set last_elapsed [expr {[set tsclock($callid)] - $tsnow}]
if {[string length $chunks($callid)] % 10 == 0 || $last_elapsed > 16} {
if {[string length $sofar] % 10 == 0 || $last_elapsed > 16} {
if {$total_elapsed > 3000} {
#REVIEW
#too long since initial read handler launched..

1
src/modules/punk/du-999999.0a1.0.tm
Unescape View File

@ -70,6 +70,7 @@ namespace eval punk::du {
proc du { args } {
variable has_twapi
#todo - use punk::args
if 0 {
switch -exact [llength $args] {

134
src/modules/punk/lib-999999.0a1.0.tm
Unescape View File

@ -301,6 +301,7 @@ tcl::namespace::eval punk::lib::compat {
if {"::lpop" ne [info commands ::lpop]} {
#puts stderr "Warning - no built-in lpop"
interp alias {} lpop {} ::punk::lib::compat::lpop
punk::args::set_alias ::punk::lib::compat::lpop ::lpop ;#point to the definition of ::lpop defined in punk::args::tclcore
}
proc lpop {lvar args} {
#*** !doctools
@ -339,6 +340,51 @@ tcl::namespace::eval punk::lib::compat {
set l $newlist
return $v
}
if {"::ledit" ni [info commands ::ledit]} {
interp alias {} ledit {} ::punk::lib::compat::ledit
punk::args::set_alias ::punk::lib::compat::ledit ::ledit
}
proc ledit {lvar first last args} {
upvar $lvar l
#use lindex_resolve to support for example: ledit lst end+1 end+1 h i
set fidx [punk::lib::lindex_resolve $l $first]
switch -exact -- $fidx {
-3 {
#index below lower bound
set pre [list]
set fidx -1
}
-2 {
#first index position is greater than index of last element in the list
set pre [lrange $l 0 end]
set fidx [llength $l]
}
default {
set pre [lrange $l 0 $first-1]
}
}
set lidx [punk::lib::lindex_resolve $l $last]
switch -exact -- $lidx {
-3 {
#index below lower bound
set post [lrange $l 0 end]
}
-2 {
#index above upper bound
set post [list]
}
default {
if {$lidx < $fidx} {
#from ledit man page:
#If last is less than first, then any specified elements will be inserted into the list before the element specified by first with no elements being deleted.
set post [lrange $l $fidx end]
} else {
set post [lrange $l $last+1 end]
}
}
}
set l [list {*}$pre {*}$args {*}$post]
}
#slight isolation - varnames don't leak - but calling context vars can be affected
@ -1137,11 +1183,13 @@ namespace eval punk::lib {
if {!$has_punk_ansi} {
set RST ""
set sep " = "
set sep_mismatch " mismatch "
#set sep_mismatch " mismatch "
set sep \u2260 ;# equivalent [punk::ansi::convert_g0 [punk::ansi::g0 |]] (not equal symbol)
} else {
set RST [punk::ansi::a]
set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support
set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST "
#set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST "
set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]\u2260$RST "
}
package require punk::pipe
#package require punk ;#we need pipeline pattern matching features
@ -1881,6 +1929,19 @@ namespace eval punk::lib {
}
proc is_list_all_in_list {small large} {
if {[llength $small] > [llength $large]} {return 0}
foreach x $large {
::set ($x) {}
}
foreach x $small {
if {![info exists ($x)]} {
return 0
}
}
return 1
}
#v2 generally seems slower
proc is_list_all_in_list2 {small large} {
set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]]
return [struct::list equal [lsort $small] $small_in_large]
}
@ -1889,11 +1950,22 @@ namespace eval punk::lib {
package require struct::list
package require struct::set
}
append body [info body is_list_all_in_list]
proc is_list_all_in_list {small large} $body
append body [info body is_list_all_in_list2]
proc is_list_all_in_list2 {small large} $body
}
proc is_list_all_ni_list {a b} {
proc is_list_all_ni_list {A B} {
foreach x $B {
::set ($x) {}
}
foreach x $A {
if {[info exists ($x)]} {
return 0
}
}
return 1
}
proc is_list_all_ni_list2 {a b} {
set i [struct::set intersect $a $b]
return [expr {[llength $i] == 0}]
}
@ -1901,8 +1973,8 @@ namespace eval punk::lib {
set body {
package require struct::list
}
append body [info body is_list_all_ni_list]
proc is_list_all_ni_list {a b} $body
append body [info body is_list_all_ni_list2]
proc is_list_all_ni_list2 {a b} $body
}
#somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist
@ -1918,7 +1990,16 @@ namespace eval punk::lib {
}
return $result
}
#with ledit (also avail in 8.6 using punk::lib::compat::ledit
proc ldiff2 {fromlist removeitems} {
if {[llength $removeitems] == 0} {return $fromlist}
foreach item $removeitems {
set posns [lsearch -all -exact $fromlist $item]
foreach p $posns {ledit fromlist $p $p}
}
return $fromlist
}
proc ldiff3 {fromlist removeitems} {
set doomed [list]
foreach item $removeitems {
lappend doomed {*}[lsearch -all -exact $fromlist $item]
@ -2160,6 +2241,41 @@ namespace eval punk::lib {
}
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side
punk::args::define {
@id -id ::punk::lib::lindex_resolve
@cmd -name punk::lib::lindex_resolve\
-summary\
"Resolve an indexexpression to an integer based on supplied list."\
-help\
"Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2
to the actual integer index for the supplied list, or to a negative value below -1 indicating
whether the index was below or above the range of possible indices for the list.
Users may define procs which accept a list index and wish to accept the forms understood by Tcl.
This means the proc may be called with something like $x+2 end-$y etc
Sometimes the actual integer index is desired.
We want to resolve the index used, without passing arbitrary expressions into the 'expr' function
- which could have security risks.
lindex_resolve will parse the index expression and return:
a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0)
b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end)
lindex_resolve never returns -1 - as the similar function lindex_resolve_basic uses this to denote
out of range at either end of the list
Otherwise it will return an integer corresponding to the position in the list.
This is in stark contrast to Tcl list function indices which will return empty strings for out of
bounds indices, or in the case of lrange, return results anyway.
Like Tcl list commands - it will produce an error if the form of the index is not acceptable
For empty lists, end and end+x indices are considered to be out of bounds on the upper side
- thus returning -2
Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command.
We will get something like 10+1 - which can be resolved safely with expr
"
@values -min 2 -max 2
list -type list
index -type indexexpression
}
proc lindex_resolve {list index} {
#*** !doctools
#[call [fun lindex_resolve] [arg list] [arg index]]
@ -2173,11 +2289,11 @@ namespace eval punk::lib {
#[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end)
#[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list
#[para]Otherwise it will return an integer corresponding to the position in the list.
#[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway.
#[para]This is in stark contrast to Tcl list function indices which will return empty strings for out of bounds indices, or in the case of lrange, return results anyway.
#[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable
#[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2
#Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr
#Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which can be resolved safely with expr
#if {![llength $list]} {
# #review
# return ???

687
src/modules/punk/libunknown-0.1.tm
Unescape View File

@ -81,14 +81,15 @@ tcl::namespace::eval punk::libunknown {
}]
variable epoch
if {![info exists epoch]} {
set tmstate [dict create 0 {}]
set pkgstate [dict create 0 {}]
set tminfo [dict create current 0 epochs $tmstate]
set pkginfo [dict create current 0 epochs $pkgstate]
#if {![info exists epoch]} {
# set tmstate [dict create 0 {}]
# set pkgstate [dict create 0 {}]
# set tminfo [dict create current 0 epochs $tmstate]
# set pkginfo [dict create current 0 epochs $pkgstate]
# set epoch [dict create tm $tminfo pkg $pkginfo]
#}
set epoch [dict create tm $tminfo pkg $pkginfo]
}
variable has_package_files
if {[catch {package files foobaz}]} {
@ -114,6 +115,19 @@ tcl::namespace::eval punk::libunknown {
# Import the pattern used to check package names in detail.
variable epoch
set pkg_epoch [dict get $epoch tm current]
set must_scan 0
if {[dict exists $epoch tm untracked $name]} {
set must_scan 1
#a package that was in the package database at the start - is now being searched for as unknown
#our epoch info is not reliable for pre-known packages - so increment the epoch and fully clear the 'added' paths even in zipfs to do proper scan
#review
#epoch_incr_pkg clearadded
#epoch_incr_tm clearadded
#puts ">>>> removing untracked tm: $name"
dict unset epoch tm untracked $name
#whie it is not the most common configuration - a package could be provided both as a .tm and by packageIndex.tcl files
}
#variable paths
@ -151,7 +165,8 @@ tcl::namespace::eval punk::libunknown {
if {![interp issafe] && ![file exists $path]} {
continue
}
set currentsearchpath [file join $path $pkgroot]
set currentsearchpath $path
set specificsearchpath [file join $path $pkgroot]
# Get the module files out of the subdirectories.
# - Safe Base interpreters have a restricted "glob" command that
@ -162,32 +177,35 @@ tcl::namespace::eval punk::libunknown {
set use_epoch_for_all 1
if {$use_epoch_for_all || [string match $zipfsroot* $path]} {
if {[dict exists $epoch tm epochs $pkg_epoch indexes $currentsearchpath]} {
if {!$must_scan && [dict exists $epoch tm epochs $pkg_epoch indexes $specificsearchpath]} {
#indexes are actual .tm files here
set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]]
set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $specificsearchpath]]
#puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles ( cached ): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath"
} else {
if {![interp issafe] && ![file exists $currentsearchpath]} {
dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create]
if {![interp issafe] && ![file exists $specificsearchpath]} {
dict set epoch tm epochs $pkg_epoch indexes $specificsearchpath [dict create]
continue
}
dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create]
dict set epoch tm epochs $pkg_epoch indexes $specificsearchpath [dict create]
# #################################################################
if {$has_zipfs && [string match $zipfsroot* $path]} {
#The entire tm tre is available so quickly from the zipfs::list call - that we can gather all at once.
set tmfiles [::tcl::zipfs::list $currentsearchpath/*.tm] ;#could theoretically be a dir - this is effectively a tree traversal
foreach tm_path $tmfiles {
dict set epoch tm epochs $pkg_epoch indexes [file dirname $tm_path] $tm_path $pkg_epoch
}
#retrieval using tcl::zipfs::list got (and cached) extras - limit to currentsearchpath
set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]]
#retrieval using tcl::zipfs::list got (and cached) extras - limit to specificsearchpath
set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $specificsearchpath]]
} else {
set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm]
#set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm]
set tmfiles [glob -nocomplain -directory $specificsearchpath *.tm]
foreach tm_path $tmfiles {
dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath $tm_path $pkg_epoch
#dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath $tm_path $pkg_epoch
dict set epoch tm epochs $pkg_epoch indexes $specificsearchpath $tm_path $pkg_epoch
}
}
#puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles (UNcached): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath"
@ -203,8 +221,8 @@ tcl::namespace::eval punk::libunknown {
set can_skip_update 0
if {[string match $zipfsroot* $path]} {
#static tm location
if {[dict exists $epoch tm epochs $pkg_epoch added $currentsearchpath]} {
if {![dict exists $epoch tm epochs $pkg_epoch added $currentsearchpath $name]} {
if {[dict exists $epoch tm epochs $pkg_epoch added $specificsearchpath]} {
if {![dict exists $epoch tm epochs $pkg_epoch added $specificsearchpath $name]} {
#$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again.
#puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP orig:$original name:$name args:$args searchpath:$currentsearchpath"
set can_skip_update 1
@ -213,19 +231,13 @@ tcl::namespace::eval punk::libunknown {
#dict unset epoch tm epochs $pkg_epoch added $currentsearchpath $name
}
}
} else {
#dynamic - can only skip if negatively cached for the current epoch
if {[dict exists $epoch tm epochs $pkg_epoch unfound $currentsearchpath $name]} {
#puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)"
set can_skip_update 1
}
}
if {!$can_skip_update} {
set strip [llength [file split $path]]
set found_name_in_currentsearchpath 0 ;#for negative cache by epoch
catch {
if {[catch {
foreach file $tmfiles {
set pkgfilename [join [lrange [file split $file] $strip end] ::]
@ -252,6 +264,20 @@ tcl::namespace::eval punk::libunknown {
# the one we already have.
# This does not apply to Safe Base interpreters because
# the token-to-directory mapping may have changed.
#JMN - review.
#dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname [dict create e $pkg_epoch v $pkgversion]
dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname $pkgversion e$pkg_epoch
if {$must_scan} {
#however - if we know we're forced to scan all tm paths we can remove discovered sibling tms from tm untracked
dict unset epoch tm untracked $pkgname
}
if {$pkgname eq $name} {
#can occur multiple times, different versions
#record package name as found in this path whether version satisfies or not
set found_name_in_currentsearchpath 1
}
#don't override the ifneeded script - for tm files the first encountered 'wins'.
continue
}
@ -273,8 +299,15 @@ tcl::namespace::eval punk::libunknown {
"[::list package provide $pkgname $pkgversion];[::list source $file]"
#JMN
#store only once for each name, although there may be multiple versions
dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname $pkg_epoch
#store only once for each name, although there may be multiple versions of same package within this searchpath
#dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname [dict create e $pkg_epoch v $pkgversion]
dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname $pkgversion e$pkg_epoch
#pkgname here could be the 'name' passed at the beggning - or other .tms at the same location.
#we can't always remove other .tms from 'tm untracked' because the search for name might skip some locations.
if {$must_scan} {
#however - if we know we're forced to scan all tm paths we can remove discovered sibling tms from tm untracked
dict unset epoch tm untracked $pkgname
}
# We abort in this unknown handler only if we got a
# satisfying candidate for the requested package.
@ -298,10 +331,8 @@ tcl::namespace::eval punk::libunknown {
set found_name_in_currentsearchpath 1
}
}
}
if {!$found_name_in_currentsearchpath} {
#can record as unfound for this path - for this epoch
dict set epoch tm epochs $pkg_epoch unfound $currentsearchpath $name 1
} errMsg]} {
puts stderr "zipfs_tm_Unknownhandler: error for tm file $file searchpath:$currentsearchpath"
}
}
@ -380,9 +411,9 @@ tcl::namespace::eval punk::libunknown {
}
if {$satisfied} {
##return
}
#if {$satisfied} {
# return
#}
}
# Fallback to previous command, if existing. See comment above about
@ -399,6 +430,25 @@ tcl::namespace::eval punk::libunknown {
variable epoch
set pkg_epoch [dict get $epoch pkg current]
#review - the ifneeded script is not the only thing required in a new interp.. consider tclIndex files and auto_load mechanism.
#also the pkgIndex.tcl could possibly provide a different ifneeded script based on interp issafe (or other interp specific things?)
#if {[dict exists $epoch scripts $name]} {
# set vscripts [dict get $epoch scripts $name]
# dict for {v scr} $vscripts {
# puts ">package ifneeded $name $v"
# package ifneeded $name $v $scr
# }
# return
#}
set must_scan 0
if {[dict exists $epoch pkg untracked $name]} {
#a package that was in the package database at the start - is now being searched for as unknown
#(due to a package forget?)
#our epoch info is not valid for pre-known packages - so setting must_scan to true
set must_scan 1
#puts ">>>> removing pkg untracked: $name"
dict unset epoch pkg untracked $name
}
#global auto_path env
global auto_path
@ -414,7 +464,7 @@ tcl::namespace::eval punk::libunknown {
set zipfsroot [tcl::zipfs::root]
set has_zipfs 1
} else {
set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands
set zipfsroot "//zipfs:/" ;#doesn't matter too much what we use here - don't expect in tm list if no zipfs commands
set has_zipfs 0
}
@ -426,6 +476,11 @@ tcl::namespace::eval punk::libunknown {
set before_dict [dict create]
#Note that autopath is being processed from the end to the front
#ie last lappended first. This means if there are duplicate versions earlier in the list,
#they will be the last to call 'package provide' for that version and so their provide script will 'win'.
#This means we should have faster filesystems such as zipfs earlier in the list.
# Cache the auto_path, because it may change while we run through the
# first set of pkgIndex.tcl files
set old_path [set use_path $auto_path]
@ -449,7 +504,7 @@ tcl::namespace::eval punk::libunknown {
set use_epoch_for_all 1
if {$use_epoch_for_all || [string match $zipfsroot* $dir]} {
set currentsearchpath $dir
if {[dict exists $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]} {
if {!$must_scan && [dict exists $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]} {
set indexfiles [dict keys [dict get $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]]
#puts stderr "--->zipfs_tclPkgUnknown $tid llength tmfiles ( cached ): [format %4d [llength $indexfiles]] name:$name searchpath:$currentsearchpath"
} else {
@ -468,8 +523,9 @@ tcl::namespace::eval punk::libunknown {
}
set can_skip_sourcing 0
if {$has_zipfs && [string match $zipfsroot* $dir]} {
#if {$has_zipfs && [string match $zipfsroot* $dir]} {
#static auto_path dirs
if {!$must_scan} {
#can avoid scan if added via this path in any epoch
if {[dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} {
if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} {
@ -483,14 +539,11 @@ tcl::namespace::eval punk::libunknown {
#dict unset epoch pkg epochs $pkg_epoch added $currentsearchpath $name
}
}
} else {
#dynamic auto_path dirs - libs could have been added/removed
#scan unless cached negative for this epoch
if {[dict exists $epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name]} {
#puts stderr "zipfs_tclPkgUnknown $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)"
set can_skip_sourcing 1
}
}
#}
#An edge case exception is that after a package forget, a deliberate call to 'package require non-existant'
#will not trigger rescans for all versions of other packages.
#A rescan of a specific package for all versions can still be triggered with a package require for
@ -498,33 +551,47 @@ tcl::namespace::eval punk::libunknown {
#(or misordered min max e.g package require md5 1-0 i.e a deliberately unsatisfiable version range)
set sourced 0
#set sourced_files [list]
if {!$can_skip_sourcing} {
#Note - naive comparison of before_pkgs vs after_pkgs isn't quite enough to tell if something was added. It could have added a version.
#this will stop us rescanning everything properly by doing a 'package require nonexistant'
#use 'info exists' to only call package names once and then append? worth it?
#use 'info exists' to only call package names once and then append?
#This could be problematic? (re-entrant tclPkgUnknown in some pkgIndex scripts?) pkgIndex.tcl scripts "shouldn't" do this?
if {![info exists before_pkgs]} {
set before_pkgs [package names]
}
#update the before_dict which persists across while loop
#we need to track the actual 'ifneeded' script not just version numbers,
#because the last ifneeded script processed for each version is the one that ultimately applies.
foreach bp $before_pkgs {
dict set before_dict $bp [package versions $bp]
#dict set before_dict $bp [package versions $bp]
foreach v [package versions $bp] {
dict set before_dict $bp $v [package ifneeded $bp $v]
}
catch {
}
}
#set before_pkgs [package names]
#catch {
foreach file $indexfiles {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
#puts stderr "----->0 sourcing $file"
#if {[string match //zipfs* $file]} {
# puts stderr "----->0 sourcing zipfs file $file"
#}
incr sourced ;#count as sourced even if source fails; keep before actual source action
#::tcl::Pkg::source $file
#lappend sourced_files $file
tcl_Pkg_source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (1)"
continue
} on error msg {
if {[regexp {version conflict for package} $msg]} {
# In case of version conflict, silently ignore
puts stderr "zipfs_tclPkgUnknown version conflict sourcing '$file' while trying to load $name (1)\nmsg:$msg"
continue
}
tclLog "error reading package index file $file: $msg"
@ -532,8 +599,11 @@ tcl::namespace::eval punk::libunknown {
set procdDirs($dir) 1
}
}
#each source operation could affect auto_path - and thus increment the pkg epoch (via trace on ::auto_path)
#e.g tcllib pkgIndex.tcl appends to auto_path
set pkg_epoch [dict get $epoch pkg current]
}
}
#}
set dir [lindex $use_path end]
if {![info exists procdDirs($dir)]} {
set file [file join $dir pkgIndex.tcl]
@ -542,20 +612,24 @@ tcl::namespace::eval punk::libunknown {
try {
#puts "----->2 sourcing $file"
incr sourced
#lappend sourced_files $file
#::tcl::Pkg::source $file
tcl_Pkg_source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (2)"
continue
} on error msg {
if {[regexp {version conflict for package} $msg]} {
# In case of version conflict, silently ignore
puts stderr "zipfs_tclPkgUnknown version conflict sourcing '$file' while trying to load $name (2)\nmsg:$msg"
continue
}
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
set pkg_epoch [dict get $epoch pkg current]
}
}
#dict set epoch pkg epochs $pkg_epoch added $currentsearchpath [dict create]
@ -569,33 +643,85 @@ tcl::namespace::eval punk::libunknown {
set after_pkgs [package names]
set just_added [dict create]
#puts "@@@@pkg epochs $pkg_epoch searchpath:$currentsearchpath name:$name before: [llength $before_pkgs] after: [llength $after_pkgs]"
if {[llength $after_pkgs] > [llength $before_pkgs]} {
foreach a $after_pkgs {
if {![dict exists $before_dict $a]} {
dict set just_added $a 1
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $pkg_epoch
foreach v [package versions $a] {
if {![dict exists $before_dict $a $v]} {
dict set just_added $a $v 1
#dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a [dict create e $pkg_epoch v $v]
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $v e$pkg_epoch
if {$must_scan} {
dict unset epoch pkg untracked $a
}
}
}
}
#puts stderr ">>>zipfs_tclPkgUnknown added [llength $added_pkgs]"
#puts stderr ">>> [join [lrange $added_pkgs 0 10] \n]..."
}
dict for {bp bpversions} $before_dict {
if {[dict exists $just_added $bp]} {
#-----------------
#if {[dict size $just_added]} {
# puts stderr "\x1b\[31m>>>zipfs_tclPkgUnknown called on name:$name added [dict size $just_added] from searchpath:$currentsearchpath\x1b\[m"
# puts stderr ">>> [join [lrange [dict keys $just_added] 0 10] \n]..."
#} else {
# tclLog ">>>zipfs_tclPkgUnknown called on name:$name Nothing added for searchpath:$currentsearchpath"
# if {[string match twapi* $name]} {
# tclLog ">>>zipfs_tclPkgUnknown: sourced_files:"
# foreach f $sourced_files {
# puts ">>> $f"
# }
# }
# if {$currentsearchpath in "//zipfs:/app //zipfs:/app/tcl_library"} {
# puts " before_pkgs: [llength $before_pkgs]"
# puts " lsearch msgcat: [lsearch $before_pkgs msgcat]"
# puts " after_pkgs: [llength $after_pkgs]"
# puts " \x1b\31mlsearch msgcat: [lsearch $after_pkgs msgcat]\x1b\[m"
# if {[lsearch $after_pkgs msgcat] >=0} {
# set versions [package versions msgcat]
# puts "msgcat versions: $versions"
# foreach v $versions {
# puts "\x1b\[32m $v ifneeded: [package ifneeded msgcat $v] \x1b\[m"
# }
# }
# }
#}
#-----------------
#review - just because this searchpath didn't add a package or add a version for the package
#it doesn't mean there wasn't a version of this package supplied there
#It may just be the same version as one we've already found.
#The last one found (earlier in auto_path) for a version is the one that supplies the final 'package provide' statement (by overriding it)
#
dict for {bp bpversionscripts} $before_dict {
if {!$must_scan && ![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $bp]} {
#puts -nonewline .
continue
}
if {[llength $bpversions] != [llength [package versions $bp]]} {
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $pkg_epoch
dict for {bv bscript} $bpversionscripts {
set nowscript [package ifneeded $bp $bv]
if {$bscript ne $nowscript} {
#ifneeded script has changed. The same version of bp was supplied on this path.
#As it's processed later - it will be the one in effect.
#dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp [dict create e $pkg_epoch v $bv]
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $bv e$pkg_epoch
dict set before_dict $bp $bv $nowscript
if {$must_scan} {
dict unset epoch pkg untracked $bp
}
}
}
#puts stderr "zipfs_tclPkgUnknown $tid sourced: $sourced (under path: $currentsearchpath)"
if {$name ni $after_pkgs} {
#cache negative result (for this epoch only)
dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1
} elseif {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} {
dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1
}
lappend before_pkgs {*}[dict keys $just_added]
#update before_pkgs & before_dict for next path
dict for {newp vdict} $just_added {
if {$newp ni $before_pkgs} {
lappend before_pkgs $newp
}
dict for {v _} $vdict {
set nowscript [package ifneeded $newp $v]
dict set before_dict $newp $v $nowscript
}
}
}
}
@ -683,17 +809,82 @@ tcl::namespace::eval punk::libunknown {
}
#puts "zipfs_tclPkgUnknown DONE"
}
variable last_auto_path
variable last_tm_paths
proc epoch_incr_pkg {args} {
if {[catch {
variable last_auto_path
global auto_path
upvar ::punk::libunknown::epoch epoch
dict set epoch scripts {}
set prev_e [dict get $epoch pkg current]
set current_e [expr {$prev_e + 1}]
# -------------
#puts stderr "--> pkg epoch $prev_e -> $current_e"
#puts stderr "args: $args"
#puts stderr "last_auto: $last_auto_path"
#puts stderr "auto_path: $auto_path"
# -------------
if {[llength $auto_path] > [llength $last_auto_path] && [punk::libunknown::lib::is_list_all_in_list $last_auto_path $auto_path]} {
#The auto_path changed, and is a pure addition of entry/entries
#commonly this is occurs where a single entry is added by a pkgIndex.Tcl
#e.g tcllib adds its base dir so that all pkgIndex.tcl files in subdirs are subsequently found
#consider autopath
#c:/libbase //zipfs:/app/libbase
#if both contain a tcllib folder with pkgIndex.tcl that extends auto_path, the auto_path extends as follows:
# -> c:/libbase //zipfs:/app/libbase //zipfs:/app/libbase/tcllib
# -> c:/libbase //zipfs:/app/libbase //zipfs:/app/libbase/tcllib c:/libbase/tcllib
#the tclPkgUnknown usedir loop (working from end of list towards beginning) will process these changes the first time dynamically
#as they occur:
#ie //zipfs:/app/libbase //zipfs:/app/libbase/tcllib c:/libbase c:/libbase/tcllib
#A subsequent scan by tclPkgUnknown on the extended auto_path would process in the order:
#c:/libbase/tcllib c:/libbase //zipfs:/app/libbase/tcllib //zipfs:/app/libbase
#re-order the new additions to come immediately following the longest common prefix entry
set newitems [punk::libunknown::lib::ldiff $auto_path $last_auto_path]
set update $last_auto_path
#no ledit or punk::lib::compat::ledit for 8.6 - so use linsert
foreach new $newitems {
set offset 0
set has_prefix 0
foreach ap [lreverse $update] {
if {[string match $ap* $new]} {
set has_prefix 1
break
}
incr offset
}
if {$has_prefix} {
set update [linsert $update end-$offset $new]
} else {
lappend update $new
}
}
set auto_path $update
}
#else - if auto_path change wasn't just extra entries - leave as user specified
#review.
set last_auto_path $auto_path
# -------------
dict set epoch pkg current $current_e
dict set epoch pkg epochs $current_e [dict create]
if {[dict exists $epoch pkg epochs $prev_e indexes]} {
#bring across the previous indexes records if static filesystem (zipfs)
if {[info commands ::tcl::zipfs::root] ne ""} {
set has_zipfs 1
} else {
set has_zipfs 0
}
if {[dict exists $epoch pkg epochs $prev_e indexes]} {
#bring across each previous 'indexes' record *if* searchpath is within zipfs root static filesystem
# and searchpath is still a path below an auto_path entry.
if {$has_zipfs} {
set zroot [zipfs root]
dict for {searchpath indexfiles} [dict get $epoch pkg epochs $prev_e indexes] {
if {[string match $zroot* $searchpath]} {
@ -710,6 +901,9 @@ tcl::namespace::eval punk::libunknown {
}
}
}
#----------------------------------------
#store basic stats for previous epoch instead of all data.
set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e indexes]]
set index_count 0
dict for {searchpath indexfiles} [dict get $epoch pkg epochs $prev_e indexes] {
@ -718,12 +912,28 @@ tcl::namespace::eval punk::libunknown {
}
dict set epoch pkg epochs $prev_e indexes_history [dict create searchpath_count $index_searchpath_count index_count $index_count]
dict unset epoch pkg epochs $prev_e indexes
#----------------------------------------
} else {
dict set epoch pkg epochs $prev_e indexes_history [dict create searchpath_count 0 index_count 0]
}
if {[dict exists $epoch pkg epochs $prev_e added]} {
#bring across - each lib will have previous epoch number
dict set epoch pkg epochs $current_e added [dict get $epoch pkg epochs $prev_e added]
if {"clearadded" in $args} {
dict set epoch pkg epochs $current_e added [dict create]
} else {
if {$has_zipfs} {
set zroot [zipfs root]
set prev_added [dict get $epoch pkg epochs $prev_e added]
set keep_added [dict filter $prev_added key $zroot*]
#bring across - each lib will have previous epoch number as the value indicating epoch in which it was found
#dict set epoch pkg epochs $current_e added [dict get $epoch pkg epochs $prev_e added]
dict set epoch pkg epochs $current_e added $keep_added
} else {
dict set epoch pkg epochs $current_e added [dict create]
}
}
#store basic stats for previous epoch
#------------------------------------
set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e added]]
set lib_count 0
dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e added] {
@ -735,37 +945,31 @@ tcl::namespace::eval punk::libunknown {
}
dict set epoch pkg epochs $prev_e added_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count]
dict unset epoch pkg epochs $prev_e added
#------------------------------------
} else {
dict set epoch pkg epochs $prev_e added_history [dict create searchpath_count 0 lib_count 0]
}
if {[dict exists $epoch pkg epochs $prev_e unfound]} {
set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e unfound]]
set lib_count 0
dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e unfound] {
dict for {lib e} $libinfo {
if {$e == $prev_e} {
incr lib_count
}
}
}
dict set epoch pkg epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count]
dict unset epoch pkg epochs $prev_e unfound
}
} errM]} {
puts stderr "epoch_incr_pkg error\n $errM"
puts stderr "epoch_incr_pkg error\n $errM\n$::errorInfo"
}
}
proc epoch_incr_tm {args} {
if {[catch {
upvar ::punk::libunknown::epoch epoch
dict set epoch scripts {}
set prev_e [dict get $epoch tm current]
set current_e [expr {$prev_e + 1}]
dict set epoch tm current $current_e
dict set epoch tm epochs $current_e [dict create]
set tmlist [tcl::tm::list]
if {[info commands ::tcl::zipfs::root] ne ""} {
set has_zipfs 1
} else {
set has_zipfs 0
}
if {[dict exists $epoch tm epochs $prev_e indexes]} {
#bring across the previous indexes records if static filesystem (zipfs)
if {[info commands ::tcl::zipfs::root] ne ""} {
if {$has_zipfs} {
set zroot [zipfs root]
dict for {searchpath indexfiles} [dict get $epoch tm epochs $prev_e indexes] {
if {[string match $zroot* $searchpath]} {
@ -795,8 +999,21 @@ tcl::namespace::eval punk::libunknown {
dict set epoch tm epochs $prev_e indexes_history [dict create searchpath_count 0 index_count 0]
}
if {[dict exists $epoch tm epochs $prev_e added]} {
#todo? cycle through non-statics and add pkgs to pkg untracked if we are deleting 'added' records?
if {"clearadded" in $args} {
dict set epoch tm epochs $current_e added [dict create]
} else {
#bring across - each lib will have previous epoch number
dict set epoch tm epochs $current_e added [dict get $epoch tm epochs $prev_e added]
#dict set epoch tm epochs $current_e added [dict get $epoch tm epochs $prev_e added]
if {$has_zipfs} {
set zroot [zipfs root]
dict set epoch tm epochs $current_e added [dict filter [dict get $epoch tm epochs $prev_e added] key $zroot*]
} else {
dict set epoch tm epochs $current_e added [dict create]
}
}
set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e added]]
set lib_count 0
dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e added] {
@ -811,26 +1028,77 @@ tcl::namespace::eval punk::libunknown {
} else {
dict set epoch tm epochs $prev_e added_history [dict create searchpath_count 0 lib_count 0]
}
if {[dict exists $epoch tm epochs $prev_e unfound]} {
set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e unfound]]
set lib_count 0
dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e unfound] {
dict for {lib e} $libinfo {
if {$e == $prev_e} {
incr lib_count
} errM]} {
puts stderr "epoch_incr_tm error\n $errM"
}
}
#see what basic info we can gather *quickly* about the indexes for each version of a pkg that the package db knows about.
#we want no calls out to the actual filesystem - but we can use some 'file' calls such as 'file dirname', 'file split' (review -safe interp problem)
#in practice the info is only available for tm modules
proc packagedb_indexinfo {pkg} {
if {[string match ::* $pkg]} {
error "packagedb_indexinfo: package name required - not a fully qualified namespace beginning with :: Received:'$pkg'"
}
dict set epoch tm epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count]
dict unset epoch tm epochs $prev_e unfound
set versions [package versions $pkg]
if {[llength $versions] == 0} {
set v [package provide $pkg]
}
} errM]} {
puts stderr "epoch_incr_tm error\n $errM"
set versionlist [list]
foreach v $versions {
set ifneededscript [package ifneeded $pkg $v]
if {[string trim $ifneededscript] eq ""} {
lappend versionlist [list $v type unknown index "" indexbase ""]
continue
}
set scriptlines [split $ifneededscript \n]
if {[llength $scriptlines] > 1} {
lappend versionlist [list $v type unknown index "" indexbase ""]
continue
}
if {[catch {llength $ifneededscript}]} {
#scripts aren't necessarily 'list shaped' - we don't want to get into the weeds trying to make sense of arbitrary scripts.
lappend versionlist [list $v type unknown index "" indexbase ""]
continue
}
if {[lindex $ifneededscript 0] eq "package" && [lindex $ifneededscript 1] eq "provide" && [file extension [lindex $ifneededscript end]] eq ".tm"} {
set tmfile [lindex $ifneededscript end]
set nspath [namespace qualifiers $pkg]
if {$nspath eq ""} {
set base [file dirname $tmfile]
} else {
set nsparts [string map {:: " "} $nspath] ;#*naive* split - we are assuming (fairly reasonably) there are no namespaces containing spaces for a .tm module
set pathparts [file split [file dirname $tmfile]]
set baseparts [lrange $pathparts 0 end-[llength $nsparts]]
set base [file join {*}$baseparts]
}
lappend versionlist [list $v type tm index $tmfile indexbase $base script $ifneededscript]
} else {
#we could guess at the pkgindex.tcl file used based on simple pkg ifneeded scripts .tcl path compared to ::auto_index
#but without hitting filesystem to verify - it's unsatisfactory
lappend versionlist [list $v type unknown index "" indexbase "" script $ifneededscript]
}
}
return $versionlist
}
proc init {args} {
variable last_auto_path
set last_auto_path [set ::auto_path]
variable last_tm_paths
set last_tm_paths [set ::tcl::tm::paths]
set callerposn [lsearch $args -caller]
if {$callerposn > -1} {
set caller [lindex $args $callerposn+1]
puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller\x1b\[m"
#puts stderr "punk::libunknown::init auto_path : $::auto_path"
#puts stderr "punk::libunknown::init tcl::tm::list: [tcl::tm::list]"
}
proc init {} {
if {[catch {tcl::tm::list} tmlist]} {
set tmlist [list]
}
@ -850,10 +1118,113 @@ tcl::namespace::eval punk::libunknown {
#This is far from conclusive - there may be other renamers (e.g commandstack)
return
}
if {[info commands ::punk::libunknown::package] ne ""} {
puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]"
return
}
variable epoch
if {![info exists epoch]} {
set tmstate [dict create 0 {added {}}]
set pkgstate [dict create 0 {added {}}]
set tminfo [dict create current 0 epochs $tmstate untracked [dict create]]
set pkginfo [dict create current 0 epochs $pkgstate untracked [dict create]]
set epoch [dict create scripts {} tm $tminfo pkg $pkginfo]
#untracked: package names at time of punk::libunknown::init call - or passed with epoch when sharing epoch to another interp.
#The epoch state will need to be incremented and cleared of any 'added' records if any of these are requested during a package unknown call
#Because they were loaded prior to us tracking the epochs - and without trying to examine the ifneeded scripts we don't know the exact paths
#which were scanned to load them. Our 'added' key entries will not contain them because they weren't unknown
} else {
#we're accepting a pre-provided 'epoch' record (probably from another interp)
#the tm untracked and pkg untracked dicts indicate for which packages the pkg added, tm added etc data are not conclusive
#test
#todo?
}
#upon first libunknown::init in the interp, we need to add any of this interp's already known packages to the (possibly existing) tm untracked and pkg untracked dicts.
#(unless we can use packagedb_indexinfo to determine what was previously scanned?)
# review - what if the auto_path or tcl::tm::list was changed between initial scan and call of libunknown::init???
# This is likely a common scenario?!!!
# For now this is a probable flaw in the logic - we need to ensure libunknown::init is done first thing
# or suffer additional scans.. or document ??
#ideally init should be called in each interp before any scans for packages so that the list of untracked is minimized.
set pkgnames [package names]
foreach p $pkgnames {
if {[string tolower $p] in {punk::libunknown tcl::zlib tcloo tcl::oo tcl}} {
continue
}
set versions [package versions $p]
if {[llength $versions] == 0} {
continue
}
set versionlist [packagedb_indexinfo $p]
if {[llength $versionlist] == 0} {
continue
} else {
foreach vdata $versionlist {
#dict set epoch scripts $p [lindex $vdata 0] [package ifneeded $p [lindex $vdata 0]]
dict set epoch scripts $p [lindex $vdata 0] [lindex $vdata 8]]
}
if {[lsearch -index 6 $versionlist ""] > -1} {
#There exists at least one empty indexbase for this package - we have to treat it as untracked
dict set epoch tm untracked $p "" ;#value unimportant
dict set epoch pkg untracked $p "" ;#value unimportant
} else {
#update the epoch info with where the tm versions came from
#(not tracking version numbers in epoch - just package to the indexbase)
foreach vdata $versionlist {
lassign $vdata v _t type _index index _indexbase indexbase
if {$type eq "tm"} {
if {![dict exists $epoch tm epochs 0 added $indexbase]} {
#dict set epoch tm epochs 0 added $indexbase [dict create $p [dict create e 0 v $v]]
dict set epoch tm epochs 0 added $indexbase $p $v e0
} else {
set idxadded [dict get $epoch tm epochs 0 added $indexbase]
#dict set idxadded $p [dict create e 0 v $v]
dict set idxadded $p $v e0
dict set epoch tm epochs 0 added $indexbase $idxadded
}
dict unset epoch tm untracked $p
} elseif {$type eq "pkg"} {
#todo? tcl doesn't give us good introspection on package indexes for packages
#dict unset epoch pkg untracked $p
}
}
}
}
}
#-------------------------------------------------------------
#set all_untracked [dict keys [dict get $epoch untracked]]
#puts stderr "\x1b\[1\;33m punk::libunknown::init - pkg all_untracked:\x1b\[m [dict size [dict get $epoch pkg untracked]]"
#if {[dict exists $epoch pkg untracked msgcat]} {
# puts stderr "\x1b\[1\;32m punk::libunknown::init msgcat found in pkg untracked \x1b\[m "
# set versions [package versions msgcat]
# puts stderr "versions: $versions"
# foreach v $versions {
# puts stdout "v $v ifneeded: [package ifneeded msgcat $v]"
# }
#} else {
# puts stderr "\x1b\[1\;31m punk::libunknown::init msgcat NOT found in pkg untracked \x1b\[m "
#}
#puts stderr "\x1b\[1\;33m punk::libunknown::init - tm all_untracked:\x1b\[m [dict size [dict get $epoch tm untracked]]"
#if {[dict exists $epoch tm untracked msgcat]} {
# puts stderr "\x1b\[1\;32m punk::libunknown::init msgcat found in tm untracked \x1b\[m "
# set versions [package versions msgcat]
# puts stderr "versions: $versions"
# foreach v $versions {
# puts stdout "v $v ifneeded: [package ifneeded msgcat $v]"
# }
#} else {
# puts stderr "\x1b\[1\;31m punk::libunknown::init msgcat NOT found in tm untracked \x1b\[m "
#}
#-------------------------------------------------------------
trace add variable ::auto_path write ::punk::libunknown::epoch_incr_pkg
trace add variable ::tcl::tm::paths write ::punk::libunknown::epoch_incr_tm
@ -870,6 +1241,7 @@ tcl::namespace::eval punk::libunknown {
#forgetting Tcl or tcl seems to be a bad idea - package require doesn't work afterwards (independent of this pkg)
set forgets_requested [lrange $args 1 end]
set ok_forgets [list]
upvar ::punk::libunknown::epoch epoch
foreach p $forgets_requested {
#'package files' not avail in early 8.6
#There can be other custom 'package ifneeded' scripts that don't use source - but still need to be forgotten.
@ -880,7 +1252,7 @@ tcl::namespace::eval punk::libunknown {
# lappend ok_forgets $p
#}
#What then? Hardcoded only for now?
if {$p ni {tcl Tcl tcl::oo}} {
if {$p ni {tcl Tcl tcl::oo tk}} {
#tcl::oo returns a comment only for its package provide script "# Already present, OK?"
# - so we can't use empty 'ifneeded' script as a determinant.
set vpresent [package provide $p]
@ -890,11 +1262,13 @@ tcl::namespace::eval punk::libunknown {
set ifneededscript [package ifneeded $p $vpresent]
if {[string trim $ifneededscript] ne ""} {
lappend ok_forgets $p
dict unset epoch scripts $p
}
} else {
#not loaded - but may have registered ifneeded script(s) in the package database
#assume ok to forget
lappend ok_forgets $p
dict unset epoch scripts $p
}
}
}
@ -1030,11 +1404,122 @@ tcl::namespace::eval punk::libunknown {
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
}
proc package_query {pkgname} {
variable epoch
if {[dict exists $epoch tm untracked $pkgname]} {
set pkg_info "$pkgname tm UNTRACKED"
} else {
set pkg_info "$pkgname not in tm untracked"
}
if {[dict exists $epoch pkg untracked $pkgname]} {
append pkg_info \n "$pkgname pkg UNTRACKED"
} else {
append pkg_info \n "$pkgname not in pkg untracked"
}
set pkg_epoch [dict get $epoch pkg current]
#set epoch_info [dict get $epoch pkg epochs $pkg_epoch]
#pkg entries are processed by package unknown in reverse - so their order of creaation is opposite to ::auto_path
set r_added [dict create]
foreach path [lreverse [dict keys [dict get $epoch pkg epochs $pkg_epoch added]]] {
dict set r_added $path [dict get $epoch pkg epochs $pkg_epoch added $path]
}
#set pkg_added [punk::lib::showdict [dict get $epoch pkg epochs $pkg_epoch added] */$pkgname]
set pkg_added [punk::lib::showdict $r_added */$pkgname]
set title "PKG epoch $pkg_epoch - added"
set added [textblock::frame -title $title $pkg_added]
set pkg_row $added
set tm_epoch [dict get $epoch tm current]
set tm_added [punk::lib::showdict [dict get $epoch tm epochs $tm_epoch added] */$pkgname]
set title "TM epoch $tm_epoch - added"
set added [textblock::frame -title $title $tm_added]
set tm_row $added
return $pkg_info\n$pkg_row\n$tm_row
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::libunknown ---}]
}
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::libunknown::lib {
#A version of textutil::string::longestCommonPrefixList
#(also as ::punk::lib::longestCommonPrefixList)
proc longestCommonPrefix {items} {
if {[llength $items] <= 1} {
return [lindex $items 0]
}
set items [lsort $items[unset items]]
set min [lindex $items 0]
set max [lindex $items end]
#if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list)
#(sort order nothing to do with length - e.g min may be longer than max)
if {[string length $min] > [string length $max]} {
set temp $min
set min $max
set max $temp
}
set n [string length $min]
set prefix ""
set i -1
while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} {
append prefix $c
}
return $prefix
}
#maint: from punk::lib::ldiff
proc ldiff {fromlist removeitems} {
if {[llength $removeitems] == 0} {return $fromlist}
set result [list]
foreach item $fromlist {
if {$item ni $removeitems} {
lappend result $item
}
}
return $result
}
proc intersect2 {A B} {
#taken from tcl version of struct::set::Intersect
if {[llength $A] == 0} {return {}}
if {[llength $B] == 0} {return {}}
# This is slower than local vars, but more robust
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
}
proc is_list_all_in_list {A B} {
if {[llength $A] > [llength $B]} {return 0}
foreach x $B {
::set ($x) {}
}
foreach x $A {
if {![info exists ($x)]} {
return 0
}
}
return 1
}
}
# -----------------------------------------------------------------------------
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked

9
src/modules/punk/mix/commandset/module-999999.0a1.0.tm
Unescape View File

@ -77,6 +77,12 @@ namespace eval punk::mix::commandset::module {
return $result
}
#require current dir when calling to be the projectdir, or
punk::args::define {
@dynamic
@id -id "::punk::mix::commandset::module::templates"
@cmd -name "punk::mix::commandset::module::templates"
${[punk::args::resolved_def -antiglobs {@id @cmd} "::punk::mix::commandset::module::templates_dict"]}
}
proc templates {args} {
set tdict_low_to_high [templates_dict {*}$args]
#convert to screen order - with higher priority at the top
@ -135,7 +141,8 @@ namespace eval punk::mix::commandset::module {
globsearches -default * -multiple 1
}
proc templates_dict {args} {
set argd [punk::args::get_by_id ::punk::mix::commandset::module::templates_dict $args]
#set argd [punk::args::get_by_id ::punk::mix::commandset::module::templates_dict $args]
set argd [punk::args::parse $args withid ::punk::mix::commandset::module::templates_dict]
package require punk::cap
if {[punk::cap::capability_has_handler punk.templates]} {
set template_folder_dict [punk::cap::call_handler punk.templates get_itemdict_moduletemplates {*}$args]

3
src/modules/punk/nav/fs-999999.0a1.0.tm
Unescape View File

@ -940,7 +940,8 @@ tcl::namespace::eval punk::nav::fs {
#windows doesn't consider dotfiles as hidden - mac does (?)
#we add dotfiles to flaggedhidden list in case there is some other mechanism that has flagged items as hidden
if {$::tcl_platform(platform) ne "windows"} {
lappend flaggedhidden {*}[lsearch -all -inline [list {*}$dirs {*}$files] ".*"]
#lappend flaggedhidden {*}[lsearch -all -inline [list {*}$dirs {*}$files] ".*"]
lappend flaggedhidden {*}[tcl::prefix::all [list {*}$dirs {*}$files] .]
#e.g we can have dupes in the case where there are vfs mounted files that appear as dirs
#as we will need to do a (nat)sort as a last step - it will be faster to not sort items prematurely
#set flaggedhidden [lsort -unique $flaggedhidden]

49
src/modules/punk/ns-999999.0a1.0.tm
Unescape View File

@ -408,6 +408,7 @@ tcl::namespace::eval punk::ns {
proc nstail {nspath args} {
#normalize the common case of ::::
set nspath [string map {:::: ::} $nspath]
#it's unusual - but namespaces *can* have spaced in them.
set mapped [string map {:: \u0FFF} $nspath]
set parts [split $mapped \u0FFF]
@ -1423,7 +1424,7 @@ tcl::namespace::eval punk::ns {
}
}
return $matches
}]
}]]
} else {
lappend matched {*}[tcl::namespace::eval $location [list ::info commands [nsjoin ${location} $p]]]
@ -2397,14 +2398,16 @@ tcl::namespace::eval punk::ns {
if {$is_ensembleparam} {
#review
lappend nextqueryargs $q
lpop queryargs_untested 0
#lpop queryargs_untested 0
ledit queryargs_untested 0 0
set specargs $queryargs_untested
continue
}
if {![llength $allchoices]} {
#review - only leaders with a defined set of choices are eligible for consideration as a subcommand
lappend nextqueryargs $q
lpop queryargs_untested 0
#lpop queryargs_untested 0
ledit queryargs_untested 0 0
set specargs $queryargs_untested
continue
}
@ -2420,7 +2423,8 @@ tcl::namespace::eval punk::ns {
}
lappend nextqueryargs $resolved_q
lpop queryargs_untested 0
#lpop queryargs_untested 0
ledit queryargs_untested 0 0
if {$resolved_q ne $q} {
#we have our first difference - recurse with new query args
set resolvelist [list {*}$specid {*}$nextqueryargs {*}$queryargs_untested]
@ -2527,6 +2531,28 @@ tcl::namespace::eval punk::ns {
set id [dict get $cmdinfo origin]
::punk::args::forms $id
}
punk::args::define {
@id -id ::punk::ns::eg
@cmd -name punk::ns::eg\
-summary\
"Return command examples."\
-help\
"Return the -help info from the @examples directive
in a command definition."
@values -min 1 -max -1
cmditem -multiple 1 -optional 0
}
proc eg {args} {
set argd [::punk::args::parse $args withid ::punk::ns::eg]
set cmdmembers [dict get $argd values cmditem]
set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context
set resolved_id [dict get $cmdinfo origin]
set result [::punk::args::eg $resolved_id]
}
punk::args::define {
@id -id ::punk::ns::synopsis
@cmd -name punk::ns::synopsis\
@ -2632,6 +2658,9 @@ tcl::namespace::eval punk::ns {
} {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} {
-form -default 0 -help\
"Ordinal index or name of command form"
-grepstr -default "" -type list -typesynopsis regex -help\
"list consisting of regex, optionally followed by ANSI names for highlighting
(incomplete - todo)"
-- -type none -help\
"End of options marker
Use this if the command to view begins with a -"
@ -2656,6 +2685,8 @@ tcl::namespace::eval punk::ns {
set querycommand [dict get $values commandpath]
set queryargs [dict get $values subcommand]
set grepstr [dict get $opts -grepstr]
set opts [dict remove $opts -grepstr]
#puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'"
#todo - similar to corp? review corp resolution process
@ -2919,7 +2950,8 @@ tcl::namespace::eval punk::ns {
break
}
lappend nextqueryargs $resolved_q
lpop queryargs_untested 0
#lpop queryargs_untested 0
ledit queryargs_untested 0 0
if {$resolved_q ne $q} {
#we have our first difference - recurse with new query args
#set numvals [expr {[llength $queryargs]+1}]
@ -3624,6 +3656,13 @@ tcl::namespace::eval punk::ns {
set msg "Undocumented command $origin. Type: $cmdtype"
}
}
if {[llength $grepstr] != 0} {
if {[llength $grepstr] == 1} {
return [punk::grepstr -no-linenumbers -highlight red [lindex $grepstr 0] $msg]
} else {
return [punk::grepstr -no-linenumbers -highlight [lrange $grepstr 1 end] [lindex $grepstr 0] $msg]
}
}
return $msg
}

60
src/modules/punk/packagepreference-999999.0a1.0.tm
Unescape View File

@ -110,9 +110,9 @@ tcl::namespace::eval punk::packagepreference {
#[list_begin definitions]
lappend PUNKARGS [list {
@id -id ::punk::packagepreference::install
@cmd -name ::punk::packagepreference::install -help\
"Install override for ::package builtin - for 'require' subcommand only."
@id -id ::punk::packagepreference::uninstall
@cmd -name ::punk::packagepreference::uninstall -help\
"Uninstall override for ::package builtin - for 'require' subcommand only."
@values -min 0 -max 0
}]
proc uninstall {} {
@ -238,18 +238,64 @@ tcl::namespace::eval punk::packagepreference {
}
}
# ---------------------------------------------------------------
set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
#??
#set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
if {[regexp {[A-Z]} $pkg]} {
#legacy package names
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation
if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} {
return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
try {
set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant]
} trap {} {emsg eopts} {
return -options $eopts $emsg
}
} else {
return $v
set require_result $v
}
} else {
return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
#return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
try {
set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant]
} trap {} {emsg eopts} {
return -options $eopts $emsg
}
}
#---------------------------------------------------------------
#load relevant punk::args::<docname> package(s)
#todo - review whether 'packagepreference' is the right place for this.
#It is conceptually different from the main functions of packagepreference,
#but we don't really want to have a chain of 'package' overrides slowing performance.
#there may be a more generic way to add soft side-dependencies that the original package doesn't/can't specify.
#---------------------------------------------------------------
set lc_pkg [string tolower $pkg]
#todo - lookup list of docpkgs for a package? from where?
#we should have the option to not load punk::args::<docpkg> at all for many(most?) cases where they're unneeded.
#e.g skip if not ::tcl_interactive?
switch -exact -- $lc_pkg {
tcl {
set docpkgs [list tclcore]
}
tk {
set docpkgs [list tkcore]
}
default {
set docpkgs [list $lc_pkg]
}
}
foreach dp $docpkgs {
#review - versions?
#we should be able to load more specific punk::args pkg based on result of [package present $pkg]
catch {
#$COMMANDSTACKNEXT require $pkg {*}$vwant
$COMMANDSTACKNEXT require punk::args::$dp
}
}
#---------------------------------------------------------------
return $require_result
}
default {
return [$COMMANDSTACKNEXT {*}$args]

6
src/modules/punk/path-999999.0a1.0.tm
Unescape View File

@ -325,7 +325,8 @@ namespace eval punk::path {
lappend finalparts ..
}
default {
lpop finalparts
#lpop finalparts
ledit finalparts end end
}
}
}
@ -345,7 +346,8 @@ namespace eval punk::path {
switch -exact -- $p {
. - "" {}
.. {
lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7
#lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7
ledit finalparts end end ;#uses punk::lib::compat::ledit if on < 8.7
}
default {
lappend finalparts $p

167
src/modules/punk/repl-999999.0a1.0.tm
Unescape View File

@ -34,6 +34,7 @@ set tcl_interactive 1
#}
#-------------------------------------------------------------------------------------
if {[package provide punk::libunknown] eq ""} {
#maintenance - also in src/vfs/_config/punk_main.tcl
set libunks [list]
foreach tm_path [tcl::tm::list] {
set punkdir [file join $tm_path punk]
@ -58,7 +59,7 @@ if {[package provide punk::libunknown] eq ""} {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init} errM]} {
if {[catch {punk::libunknown::init -caller repl} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}
@ -435,6 +436,19 @@ proc repl::start {inchan args} {
} else {
set start_in_ns ::
}
set einf [thread::send $codethread {
set ::codethread_initstatus
}]
if {[lindex $einf 0] ne "ok"} {
set err [thread::send $codethread {
set ::errorInfo
}]
puts "--------------------> codethread initstatus: $einf"
puts "--------------------> codethread last err: $err"
}
thread::send $codethread [string map [list %ns1% $start_in_ns] {
#set ::punk::repl::codethread::running 1
@ -633,7 +647,11 @@ proc repl::screen_last_char_add {c what {why ""}} {
}
if {[string length $screen_last_chars] > 10} {
set screen_last_chars [string range $screen_last_chars 1 end] ;#evict first char
set screen_last_char_list [lrange $screen_last_char_list 1 end]
#set screen_last_char_list [lrange $screen_last_char_list 1 end]
#native lpop or punk::lib::compat::lpop
#lpop screen_last_char_list 0
#native ledit or punk::lib::compat::ledit
ledit screen_last_char_list 0 0
}
append screen_last_chars $c
lappend screen_last_char_list [list $c $what $why]
@ -1425,9 +1443,10 @@ proc repl::repl_handler {inputchan prompt_config} {
set input_chunks_waiting($inputchan) [list]
set yellow [punk::ansi::a+ yellow bold]
set waitinglines [split $allwaiting \n]
foreach ln [lrange $waitinglines 0 end-1] {
lappend stdinlines $ln
}
#foreach ln [lrange $waitinglines 0 end-1] {
# lappend stdinlines $ln
#}
lappend stdinlines {*}[lrange $waitinglines 0 end-1]
set waitingchunk [lindex $waitinglines end]
# --
#set chunksize [gets $inputchan chunk]
@ -2003,10 +2022,14 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
}
} else {
if {$nextsubmit_line_num < $last_line_num} {
foreach ln [$editbuf lines $nextsubmit_line_num end-1] {
lappend stdinlines $ln
incr editbuf_linenum_submitted
}
#foreach ln [$editbuf lines $nextsubmit_line_num end-1] {
# lappend stdinlines $ln
# incr editbuf_linenum_submitted
#}
#xxx
set slines [$editbuf lines $nextsubmit_line_num end-1]
lappend stdinlines {*}$slines
incr editbuf_linenum_submitted [llength $slines]
}
}
set last_cursor_column [$editbuf cursor_column]
@ -2251,11 +2274,17 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
thread::send -async $codethread [list punk::repl::codethread::runscript $run_command_string]
thread::mutex lock $codethread_mutex
while {[set status [tsv::get codethread_$codethread status]] == -1} {
thread::cond wait $codethread_cond $codethread_mutex 50
update ;#we need a full update here to allow interrupts to be processed
#While update is often considered risky - here we know our input channel readable event has been disabled - so re-entrancy shouldn't be possible.
#however - child thread can send quit - transferring processing from here back to repl::start - which then ends - making a mess (child not yet finished when trying to tidy up)
#we should give the child a way to quit by setting a tsv we pick up here *after the while loop* - and then we can set done.
#An example of a case where the update is required is when the script needs to do a thread::send back to this thread to calculate its result.
#e.g repl::interphelpers::colour
#thread::cond wait $codethread_cond $codethread_mutex 2 ;#2025-07-13 seems to work reasonably
thread::cond wait $codethread_cond $codethread_mutex 1
}
thread::mutex unlock $codethread_mutex
set raw_result [tsv::get codethread_$codethread result]
@ -2729,6 +2758,7 @@ namespace eval repl {
]
#scriptmap applied at end to satisfy silly editor highlighting.
set init_script {
set ::codethread_initstatus [list [list started [clock seconds]]]
set ::argv0 %argv0%
set ::argv %argv%
set ::argc %argc%
@ -2784,21 +2814,42 @@ namespace eval repl {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init} errM]} {
puts "error initialising punk::libunknown\n$errM"
if {[catch {punk::libunknown::init -caller "repl init_script"} errM]} {
puts "repl::init problem - error initialising punk::libunknown\n$errM"
}
#package require punk::lib
#puts [punk::libunknown::package_query snit]
} else {
puts "repl::init problem - can't load punk::libunknown"
}
#-----------------------------------------------------------------------------
package require punk::packagepreference
punk::packagepreference::install
package require punk::ansi::colourmap
package require punk::args
package require Thread
package require snit
#package require Thread
if {[catch {package require thread} errM]} {
puts stdout "initscript lib load fail on package require thread\n$errM"
puts stdout ">>auto_path : $::auto_path"
puts stdout ">>tcl::tm::list: [tcl::tm::list]"
}
#-----
#review - icomm as a possible way to talk to thread outside of the code interp.
#thread::send msgs arrive at a specific interp based on initial setup - review for when/whether androwish thread enhancements are made to allow
#thread::send to caller defined interp targets (reference?)
#snit required for icomm
if {[catch {package require snit} errM]} {
puts stdout "punk::repl::initscript lib load fail ---snit $errM"
}
if {[catch {package require punk::icomm} errM]} {
puts stdout "---icomm $errM"
puts stdout "punk::repl::initscript lib load fail ---icomm $errM"
}
#-----
namespace eval ::punk::repl::codethread {}
#todo - review. According to fifo2 docs Memchan involves one less thread (may offer better performance/resource use)
catch {package require tcl::chan::fifo2}
@ -2806,15 +2857,16 @@ namespace eval repl {
#first use can raise error being a version number e.g 0.1.0 - why?
lassign [tcl::chan::fifo2] ::punk::repl::codethread::repltalk replside
} errMsg]} {
#puts stdout "---tcl::chan::fifo2 error: $errM"
puts stdout "punk::repl::initscript tcl::chan::fifo2 error: $errM"
} else {
#experimental?
#puts stdout "transferring chan $replside to thread %replthread%"
#flush stdout
if {[catch {
#after 0 [list thread::transfer %replthread% $replside]
} errMsg]} {
#puts stdout "---thread::transfer error: $errMsg"
}
#if {[catch {
# #after 0 [list thread::transfer %replthread% $replside]
#} errMsg]} {
# #puts stdout "---thread::transfer error: $errMsg"
#}
}
package require punk::console
@ -3043,7 +3095,10 @@ namespace eval repl {
switch -- $safe {
safe {
interp create -safe -- code
package require punk::args
code eval [list namespace eval ::punk::libunknown {}]
catch {
code eval [list set ::punk::libunknown::epoch $::punk::libunknown::epoch]
}
}
safebase {
safe::interpCreate code -nested 1 -autoPath %autopath%
@ -3071,6 +3126,9 @@ namespace eval repl {
interp create code
code eval [list namespace eval ::punk::libunknown {}]
catch {
#JJJ REVIEW.
#If libunknown was loaded when packages already in the package database
#then the epoch info may be wrong.
code eval [list set ::punk::libunknown::epoch $::punk::libunknown::epoch]
}
}
@ -3093,6 +3151,8 @@ namespace eval repl {
}
}
#todo a specific punk::libunknown 'package unknown' handler for safe interps
#pull in code via calls to source cached code?
switch -- $safe {
safe {
if {[llength $paths]} {
@ -3101,9 +3161,22 @@ namespace eval repl {
punk::island::add code $p
}
}
interp share "" stdout code
interp share "" stderr code
interp share "" stdin code ;#needed for ANSI queries
#interp share "" stdout code
#interp share "" stderr code
#interp share "" stdin code ;#needed for ANSI queries
interp eval code [list set ::tcl_platform(os) $::tcl_platform(os)]
interp eval code [list set ::tcl_platform(osVersion) $::tcl_platform(osVersion)]
interp eval code [list set ::tcl_platform(machine) $::tcl_platform(machine)]
if {"stdout" in [chan names]} {
interp share {} stdout code
} else {
interp share {} [shellfilter::stack::item_tophandle stdout] code
}
if {"stderr" in [chan names]} {
interp share {} stderr code
} else {
interp share {} [shellfilter::stack::item_tophandle stderr] code
}
set codehidden [code hidden]
code alias file file
@ -3124,7 +3197,17 @@ namespace eval repl {
code expose tcl:info:cmdtype
code eval {rename tcl:info:cmdtype ::tcl::info::cmdtype}
}
#package require punk::libunknown
#package require punk::args
#code eval {
# package require punk::libunknown
# punk::libunknown::init -caller safe
#}
set pkgs [list\
punk::ansi::colourmap\
punk::args\
punk::pipe\
cmdline\
@ -3173,6 +3256,7 @@ namespace eval repl {
#----------
set prior_infoscript [code eval {info script}] ;#probably empty that's ok
foreach pkg $pkgs {
#puts stderr "---> init_script safe pkg: $pkg"
if {[catch {
set nsquals [namespace qualifiers $pkg]
if {$nsquals ne ""} {
@ -3202,11 +3286,14 @@ namespace eval repl {
} errMsg]} {
puts stderr "safe - failed to load package $pkg\n$errMsg\n$::errorInfo"
} else {
#puts stdout "safe - loaded $pkg from $path"
#puts stdout "---> init_script safe - loaded $pkg from $path"
#puts stdout "---> v [code eval [list package provide $pkg]]"
}
}
code alias file ""
code hide source
#JJJJ
#code alias file ""
#code hide source
#review argv0,argv,argc
@ -3214,19 +3301,6 @@ namespace eval repl {
# set ::argv0 %argv0%
# set ::auto_path %autopath%
#}
interp eval code [list set ::tcl_platform(os) $::tcl_platform(os)]
interp eval code [list set ::tcl_platform(osVersion) $::tcl_platform(osVersion)]
interp eval code [list set ::tcl_platform(machine) $::tcl_platform(machine)]
if {"stdout" in [chan names]} {
interp share {} stdout code
} else {
interp share {} [shellfilter::stack::item_tophandle stdout] code
}
if {"stderr" in [chan names]} {
interp share {} stderr code
} else {
interp share {} [shellfilter::stack::item_tophandle stderr] code
}
#review
code alias ::shellfilter::stack ::shellfilter::stack
@ -3454,7 +3528,7 @@ namespace eval repl {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init} errM]} {
if {[catch {punk::libunknown::init -caller "repl init_script punk"} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}
@ -3462,6 +3536,8 @@ namespace eval repl {
puts stderr "punk::libunknown [package provide punk::libunknown] already loaded"
}
#-----------------------------------------------------------------------------
#package require punk::packagepreference
#punk::packagepreference::install
# -- ---
#review
@ -3516,6 +3592,9 @@ namespace eval repl {
puts stderr $errM
puts stderr $::errorInfo
puts stderr "========================"
puts stderr "auto_path: $::auto_path"
puts stderr "========================"
lappend ::codethread_initstatus "error $errM"
error "$errM"
}
}
@ -3548,6 +3627,9 @@ namespace eval repl {
#puts stderr "returning threadid"
#puts stderr [thread::id]
if {[llength $::codethread_initstatus] == 1} {
set ::codethread_initstatus [linsert $::codethread_initstatus 0 ok]
}
thread::id
}
set init_script [string map $scriptmap $init_script]
@ -3557,6 +3639,7 @@ namespace eval repl {
if {![catch {
thread::send $codethread $init_script result ;#use a result var when wrapping in a catch - without it we can get a return code of 2 (TCL_RETURN)
} errMsg]} {
#puts stderr "punk::repl sent init_script to codethread id $codethread"
return $result
} else {
puts stderr "repl::init Failed during thread::send"

2
src/modules/punk/repl-buildversion.txt
Unescape View File

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

2
src/modules/punk/repl/codethread-999999.0a1.0.tm
Unescape View File

@ -116,7 +116,7 @@ tcl::namespace::eval punk::repl::codethread {
#review/test
catch {package require punk::ns}
catch {package rquire punk::repl}
catch {package require punk::repl}
#variable xyz

183
src/modules/shellfilter-0.1.9.tm → src/modules/shellfilter-0.2.tm
Unescape View File

@ -336,10 +336,12 @@ namespace eval shellfilter::chan {
variable o_datavars
variable o_trecord
variable o_enc
variable o_encbuf
variable o_is_junction
constructor {tf} {
set o_trecord $tf
set o_enc [tcl::dict::get $tf -encoding]
set o_encbuf ""
set settingsdict [tcl::dict::get $tf -settings]
set varname [tcl::dict::get $settingsdict -varname]
set o_datavars $varname
@ -365,15 +367,51 @@ namespace eval shellfilter::chan {
#method read {ch count} {
# return ?
#}
method flush {ch} {
return ""
#method flush {ch} {
# return ""
#}
method flush {transform_handle} {
#puts stdout "<flush>"
#review - just clear o_encbuf and emit nothing?
#we wouldn't have a value there if it was convertable from the channel encoding?
set clear $o_encbuf
set o_encbuf ""
return $o_encbuf
}
method write {ch bytes} {
set stringdata [tcl::encoding::convertfrom $o_enc $bytes]
#test with set x [string repeat " \U1f6c8" 2043]
#or
#test with set x [string repeat " \U1f6c8" 683]
#most windows terminals (at least) may emit two unrecognised chars "??" at the end
#Our goal with the while loop here is to avoid encoding conversion errors
#the source of the bogus chars in terminals is unclear.
#Alacritty on windows doesn't seem to have the problem, but wezterm,cmd,windows terminal do.
#set stringdata [tcl::encoding::convertfrom $o_enc $bytes]
set inputbytes $o_encbuf$bytes
set o_encbuf ""
set tail_offset 0
while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} {
incr tail_offset
}
if {$tail_offset > 0} {
if {$tail_offset < [string length $inputbytes]} {
#stringdata from catch statement must be a valid result
set t [expr {$tail_offset - 1}]
set o_encbuf [string range $inputbytes end-$t end]
} else {
set stringdata ""
set o_encbuf $inputbytes
return ""
}
}
foreach v $o_datavars {
append $v $stringdata
}
return $bytes
#return $bytes
return [string range $inputbytes 0 end-$tail_offset]
}
method meta_is_redirection {} {
return $o_is_junction
@ -383,11 +421,13 @@ namespace eval shellfilter::chan {
variable o_logsource
variable o_localchan
variable o_enc
variable o_encbuf
variable o_trecord
variable o_is_junction
constructor {tf} {
set o_trecord $tf
set o_enc [tcl::dict::get $tf -encoding]
set o_encbuf ""
set settingsdict [tcl::dict::get $tf -settings]
if {![dict exists $settingsdict -tag]} {
error "tee_to_pipe constructor settingsdict missing -tag"
@ -424,13 +464,34 @@ namespace eval shellfilter::chan {
return $bytes
}
method flush {transform_handle} {
return ""
#return ""
set clear $o_encbuf
set o_encbuf ""
return $o_encbuf
}
method write {transform_handle bytes} {
set logdata [tcl::encoding::convertfrom $o_enc $bytes]
#set logdata [tcl::encoding::convertfrom $o_enc $bytes]
set inputbytes $o_encbuf$bytes
set o_encbuf ""
set tail_offset 0
while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} {
incr tail_offset
}
if {$tail_offset > 0} {
if {$tail_offset < [string length $inputbytes]} {
#stringdata from catch statement must be a valid result
set t [expr {$tail_offset - 1}]
set o_encbuf [string range $inputbytes end-$t end]
} else {
set stringdata ""
set o_encbuf $inputbytes
return ""
}
}
#::shellfilter::log::write $o_logsource $logdata
puts -nonewline $o_localchan $logdata
return $bytes
puts -nonewline $o_localchan $stringdata
#return $bytes
return [string range $inputbytes 0 end-$tail_offset]
}
#a tee is not a redirection - because data still flows along the main path
method meta_is_redirection {} {
@ -443,10 +504,12 @@ namespace eval shellfilter::chan {
variable o_logsource
variable o_trecord
variable o_enc
variable o_encbuf
variable o_is_junction
constructor {tf} {
set o_trecord $tf
set o_enc [tcl::dict::get $tf -encoding]
set o_encbuf ""
set settingsdict [tcl::dict::get $tf -settings]
if {![tcl::dict::exists $settingsdict -tag]} {
error "tee_to_log constructor settingsdict missing -tag"
@ -460,7 +523,7 @@ namespace eval shellfilter::chan {
}
}
method initialize {ch mode} {
return [list initialize read write finalize]
return [list initialize read write flush finalize]
}
method finalize {ch} {
::shellfilter::log::close $o_logsource
@ -475,10 +538,34 @@ namespace eval shellfilter::chan {
::shellfilter::log::write $o_logsource $logdata
return $bytes
}
method flush {transform_handle} {
#return ""
set clear $o_encbuf
set o_encbuf ""
return $o_encbuf
}
method write {ch bytes} {
set logdata [tcl::encoding::convertfrom $o_enc $bytes]
#set logdata [tcl::encoding::convertfrom $o_enc $bytes]
set inputbytes $o_encbuf$bytes
set o_encbuf ""
set tail_offset 0
while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} {
incr tail_offset
}
if {$tail_offset > 0} {
if {$tail_offset < [string length $inputbytes]} {
#stringdata from catch statement must be a valid result
set t [expr {$tail_offset - 1}]
set o_encbuf [string range $inputbytes end-$t end]
} else {
set stringdata ""
set o_encbuf $inputbytes
return ""
}
}
::shellfilter::log::write $o_logsource $logdata
return $bytes
#return $bytes
return [string range $inputbytes 0 end-$tail_offset]
}
method meta_is_redirection {} {
return $o_is_junction
@ -491,9 +578,11 @@ namespace eval shellfilter::chan {
variable o_logsource
variable o_trecord
variable o_enc
variable o_encbuf
constructor {tf} {
set o_trecord $tf
set o_enc [dict get $tf -encoding]
set o_encbuf ""
set settingsdict [dict get $tf -settings]
if {![dict exists $settingsdict -tag]} {
error "logonly constructor settingsdict missing -tag"
@ -516,24 +605,27 @@ namespace eval shellfilter::chan {
# return ?
#}
method write {transform_handle bytes} {
set logdata [encoding convertfrom $o_enc $bytes]
if 0 {
if {"utf-16le" in [encoding names]} {
set logdata [encoding convertfrom utf-16le $bytes]
} else {
set logdata [encoding convertto utf-8 $bytes]
#set logdata [encoding convertfrom unicode $bytes]
#set logdata $bytes
#set logdata [encoding convertfrom $o_enc $bytes]
set inputbytes $o_encbuf$bytes
set o_encbuf ""
set tail_offset 0
while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} {
incr tail_offset
}
if {$tail_offset > 0} {
if {$tail_offset < [string length $inputbytes]} {
#stringdata from catch statement must be a valid result
set t [expr {$tail_offset - 1}]
set o_encbuf [string range $inputbytes end-$t end]
} else {
set stringdata ""
set o_encbuf $inputbytes
return
}
}
#set logdata $bytes
#set logdata [string map [list \r -r- \n -n-] $logdata]
#if {[string equal [string range $logdata end-1 end] "\r\n"]} {
# set logdata [string range $logdata 0 end-2]
#}
#::shellfilter::log::write_sync $o_logsource $logdata
::shellfilter::log::write $o_logsource $logdata
#return $bytes
::shellfilter::log::write $o_logsource $stringdata
return
}
method meta_is_redirection {} {
@ -640,13 +732,14 @@ namespace eval shellfilter::chan {
oo::class create ansiwrap {
variable o_trecord
variable o_enc
variable o_encbuf ;#buffering for partial encoding bytes
variable o_colour
variable o_do_colour
variable o_do_normal
variable o_is_junction
variable o_codestack
variable o_gx_state ;#on/off alt graphics
variable o_buffered
variable o_buffered ;#buffering for partial ansi codes
constructor {tf} {
package require punk::ansi
set o_trecord $tf
@ -663,6 +756,7 @@ namespace eval shellfilter::chan {
}
set o_codestack [list]
set o_gx_state [expr {off}]
set o_encbuf ""
set o_buffered "" ;#hold back data that potentially contains partial ansi codes
if {[tcl::dict::exists $tf -junction]} {
set o_is_junction [tcl::dict::get $tf -junction]
@ -925,14 +1019,34 @@ namespace eval shellfilter::chan {
}
method flush {transform_handle} {
#puts stdout "<flush>"
set emit [tcl::encoding::convertto $o_enc $o_buffered]
set inputbytes $o_buffered$o_encbuf
set emit [tcl::encoding::convertto $o_enc $inputbytes]
set o_buffered ""
set o_encbuf ""
return $emit
return
}
method write {transform_handle bytes} {
set instring [tcl::encoding::convertfrom $o_enc $bytes]
set streaminfo [my Trackcodes $instring]
#set instring [tcl::encoding::convertfrom $o_enc $bytes] ;naive approach will break due to unexpected byte sequence - occasionally
#bytes can break at arbitrary points making encoding conversions invalid.
set inputbytes $o_encbuf$bytes
set o_encbuf ""
set tail_offset 0
while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} {
incr tail_offset
}
if {$tail_offset > 0} {
if {$tail_offset < [string length $inputbytes]} {
#stringdata from catch statement must be a valid result
set t [expr {$tail_offset - 1}]
set o_encbuf [string range $inputbytes end-$t end]
} else {
set stringdata ""
set o_encbuf $inputbytes
return ""
}
}
set streaminfo [my Trackcodes $stringdata]
set emit [dict get $streaminfo emit]
#review - wrapping already done in Trackcodes
@ -947,12 +1061,11 @@ namespace eval shellfilter::chan {
#} else {
# set outstring $emit
#}
set outstring $emit
#set outstring $emit
#puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<"
#puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<"
return [tcl::encoding::convertto $o_enc $outstring]
return [tcl::encoding::convertto $o_enc $emit]
}
method Write_naive {transform_handle bytes} {
set instring [tcl::encoding::convertfrom $o_enc $bytes]
@ -3205,5 +3318,5 @@ namespace eval shellfilter {
package provide shellfilter [namespace eval shellfilter {
variable version
set version 0.1.9
set version 0.2
}]

80
src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-0.1.1_testsuites/ansi/ansistrip.test
Unescape View File

@ -0,0 +1,80 @@
package require tcltest
namespace eval ::testspace {
namespace import ::tcltest::*
variable common {
set result ""
}
test ansistrip_basic_sgr_strip {test ansistrip on basic SGR colour code and reset}\
-setup $common -body {
set a "\x1b\[31mxxx\x1b\[myyy" ;# set a [a+ red]xxx[a]yyy
lappend result [punk::ansi::ansistrip $a]
}\
-cleanup {
}\
-result [list\
xxxyyy
]
test ansistrip_nonansi_escape {test ansistrip on non-ansi ESC}\
-setup $common -body {
set a \x1bxxx ;#not an SGR or other known ansi sequence - should pass through
set b [punk::ansi::ansistrip $a]
lappend result [string equal $a $b]
}\
-cleanup {
}\
-result [list\
1
]
test ansistrip_movement {test ansistrip on ANSI move}\
-setup $common -body {
set a X\x1b\[2\;2HY ;#not an SGR or other known ansi sequence - should pass through
#equivalent to : set a X[move 2 2]Y
lappend result [punk::ansi::ansistrip $a]
}\
-cleanup {
}\
-result [list\
XY
]
test ansistrip_privacymessage_7bit {test ansistrip on a 7bit privacymessage strips entire pm}\
-setup $common -body {
#regardless of whether various terminals display the PM contents or not - this is required to be stripped here.
set a "7bit secret \x1b^UN\x1b\\safe"
#equivalent to : set a X[move 2 2]Y
lappend result [punk::ansi::ansistrip $a]
}\
-cleanup {
}\
-result [list\
"7bit secret safe"
]
test ansistrip_privacymessage_8bit {test ansistrip on a 8bit privacymessage strips entire pm}\
-setup $common -body {
#regardless of whether various terminals display the PM contents or not - this is required to be stripped here.
set a "8bit secret \x9eUN\x9csafe"
#equivalent to : set a X[move 2 2]Y
lappend result [punk::ansi::ansistrip $a]
}\
-cleanup {
}\
-result [list\
"8bit secret safe"
]
test ansistrip_converts_vt100_gx {test ansistrip converts vt100 graphical symbols to unicode equivalent}\
-setup $common -body {
set a "\x1b(0|\x1b(B" ;#equivalent [punk::ansi::g0 |]
lappend result [punk::ansi::ansistrip $a] ;#unicode not-equal symbol \u2260
}\
-cleanup {
}\
-result [list\
\u2260
]
}

0
src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-0.1.1_testsuites/tests/ansistrip.test#..+ansi+ansistrip.test.fauxlink
Unescape View File

225
src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-999999.0a1.0.tm
Unescape View File

@ -0,0 +1,225 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# 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) 2025
#
# @@ Meta Begin
# Application test::punk::ansi 999999.0a1.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_test::punk::ansi 0 999999.0a1.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require test::punk::ansi]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of test::punk::ansi
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by test::punk::ansi
#[list_begin itemized]
package require Tcl 8.6-
#*** !doctools
#[item] [package {Tcl 8.6}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
tcl::namespace::eval test::punk::ansi {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection {Namespace test::punk::ansi}]
#[para] Core API functions for test::punk::ansi
#[list_begin definitions]
variable PUNKARGS
variable pkg test::punk::ansi
variable version
set version 999999.0a1.0
package require packageTest
packageTest::makeAPI test::punk::ansi $version punk::ansi; #will package provide test::punk::args $version
package forget punk::ansi
package require punk::ansi
#*** !doctools
#[list_end] [comment {--- end definitions namespace test::punk::ansi ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval test::punk::ansi::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace test::punk::ansi::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 test::punk::ansi::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval test::punk::ansi {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
variable PUNKARGS
variable PUNKARGS_aliases
lappend PUNKARGS [list {
@id -id "(package)test::punk::ansi"
@package -name "test::punk::ansi" -help\
"test suite for punk::ansi"
}]
namespace eval argdoc {
#namespace for custom argument documentation
proc package_name {} {
return test::punk::ansi
}
proc about_topics {} {
#info commands results are returned in an arbitrary order (like array keys)
set topic_funs [info commands [namespace current]::get_topic_*]
set about_topics [list]
foreach f $topic_funs {
set tail [namespace tail $f]
lappend about_topics [string range $tail [string length get_topic_] end]
}
#Adjust this function or 'default_topics' if a different order is required
return [lsort $about_topics]
}
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
# get_topic_ functions add more to auto-include in about topics
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr [string trim {
package test::punk::ansi
} \n]
}
proc get_topic_License {} {
return "MIT"
}
proc get_topic_Version {} {
return "$::test::punk::ansi::version"
}
proc get_topic_Contributors {} {
set authors {{Julian Noble <julian@precisium.com.au}}
set contributors ""
foreach a $authors {
append contributors $a \n
}
if {[string index $contributors end] eq "\n"} {
set contributors [string range $contributors 0 end-1]
}
return $contributors
}
# -------------------------------------------------------------
}
# we re-use the argument definition from punk::args::standard_about and override some items
set overrides [dict create]
dict set overrides @id -id "::test::punk::ansi::about"
dict set overrides @cmd -name "test::punk::ansi::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About test::punk::ansi
}] \n]
dict set overrides topic -choices [list {*}[test::punk::ansi::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
dict set overrides topic -default [test::punk::ansi::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *]
lappend PUNKARGS [list $newdef]
proc about {args} {
package require punk::args
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on
set argd [punk::args::parse $args withid ::test::punk::ansi::about]
lassign [dict values $argd] _leaders opts values _received
punk::args::package::standard_about -package_about_namespace ::test::punk::ansi::argdoc {*}$opts {*}[dict get $values topic]
}
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===
# -----------------------------------------------------------------------------
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked
# -----------------------------------------------------------------------------
# variable PUNKARGS
# variable PUNKARGS_aliases
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::test::punk::ansi
}
# -----------------------------------------------------------------------------
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide test::punk::ansi [tcl::namespace::eval test::punk::ansi {
variable pkg test::punk::ansi
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]

77
src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test
Unescape View File

@ -279,4 +279,81 @@ namespace eval ::testspace {
{-direction u}
]
test parse_withdef_choice_multiple_multiple {test -choice with both -multiple and -choicemultiple}\
-setup $common -body {
set argd [punk::args::parse {a {c a} {a b c}} withdef @values {X -type string -choices {aa bb cc} -multiple 1 -choicemultiple {1 3} -optional 1}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{X {aa {cc aa} {aa bb cc}}}
]
#todo - decide on whether -choicemultiple should disallow duplicates in result by default
test parse_withdef_leader_literalprefix_fullvalue {leaders - ensure supplying a prefix of literalprefix(test) returns full value 'test'}\
-setup $common -body {
set argd [punk::args::parse {t} withdef @leaders {A -type literalprefix(test)}]
lappend result [dict get $argd leaders]
}\
-cleanup {
}\
-result [list\
{A test}
]
test parse_withdef_value_literalprefix_fullvalue {values - ensure supplying a prefix of literalprefix(test) returns full value 'test'}\
-setup $common -body {
set argd [punk::args::parse {t} withdef @values {A -type literalprefix(test)}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{A test}
]
test parse_withdef_value_literal_alternates_case {values - ensure literal alternates work and preserve case}\
-setup $common -body {
set argd [punk::args::parse {abc} withdef @values {A -type literal(abc)|literal(DeF)}]
lappend result [dict get $argd values]
set argd [punk::args::parse {DeF} withdef @values {A -type literal(abc)|literal(DeF)}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{A abc} {A DeF}
]
test parse_withdef_value_literalprefix_literal_combo {values - ensure literal/literalprefix prefix calculation works}\
-setup $common -body {
set argd [punk::args::parse {test} withdef @values {A -type literalprefix(testinfo)|literal(test)}]
lappend result [dict get $argd values]
set argd [punk::args::parse {testin} withdef @values {A -type literalprefix(testinfo)|literal(test)}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{A test} {A testinfo}
]
test parse_withdef_value_alternatetypes {values - ensure alternate types (in simple-syntax) pass validation}\
-setup $common -body {
#both should pass validation
set argd [punk::args::parse {a} withdef @values {A -type int|char}]
lappend result [dict get $argd values]
set argd [punk::args::parse {11} withdef @values {A -type char|int}]
lappend result [dict get $argd values]
#todo RPN?
#set argd [punk::args::parse {11} withdef @values {A -type {char int OR}}]
#set argd [punk::args::parse {11} withdef @values {A -type {char int stringstartswith | OR}}]
}\
-cleanup {
}\
-result [list\
{A a} {A 11}
]
}

3
src/modules/test/punk/ansi-buildversion.txt
Unescape View File

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

3
src/modules/textblock-999999.0a1.0.tm
Unescape View File

@ -7924,7 +7924,8 @@ tcl::namespace::eval textblock {
if {[lindex $args end-1] eq "--"} {
set contents [lpop optlist end]
set has_contents 1
lpop optlist end ;#drop the end-of-opts flag
#lpop optlist end
ledit optlist end end;#drop the end-of-opts flag
} else {
set optlist $args
set contents ""

152
src/vfs/_config/punk_main.tcl
Unescape View File

@ -106,6 +106,24 @@ apply { args {
}
# -- --- ---
#maintain a separate auto_path_additions
# - we add to both tail and head of this depending on internal/external - and then append to existing auto_path
#ie existing auto_path from env etc has precedence over what we add.
set auto_path_additions [list]
set lc_auto_path [string tolower $::auto_path]
#inital auto_path setup by init.tcl
#firstly it includes env(TCLLIBPATH)
#then it adds the tcl_library folder and its parent
#e.g //zipfs:/app/tcl_library and //zipfs:/app
#all our auto_path_additions will come after these - and thus are lower priority.
#when 'dev' is not supplied - any non internal paths (usually those from env(TCLLIBPATH) will be stripped
#so that everything is self-contained in the kit/zipkit
#when 'dev' is supplied - the executable or script relative paths will be placed before other internal paths - except for those that init.tcl set up
#todo - place externals from TCLLIBPATH at end so lower priority than dev paths.
#puts "\x1b\[1\;33m main.tcl original auto_path: $::auto_path"
if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} {
set kp $::tcl::kitpath
set existing_module_paths [string tolower [tcl::tm::list]]
@ -115,8 +133,8 @@ apply { args {
}
}
foreach l [list lib lib_tcl$tclmajorv] {
if {[string tolower [file join $kp $l]] ni [string tolower $::auto_path]} {
lappend ::auto_path [file join $kp $l]
if {[string tolower [file join $kp $l]] ni [list {*}$lc_auto_path {*}$auto_path_additions]} {
lappend auto_path_additions [file join $kp $l]
}
}
}
@ -132,8 +150,8 @@ apply { args {
}
}
foreach l [list lib lib_tcl$tclmajorv] {
if {[string tolower [file join $zipbase $l]] ni [string tolower $::auto_path]} {
lappend ::auto_path [file join $zipbase $l]
if {[string tolower [file join $zipbase $l]] ni [list {*}$lc_auto_path {*}$auto_path_additions]} {
lappend auto_path_additions [file join $zipbase $l]
}
}
}
@ -146,8 +164,8 @@ apply { args {
}
}
foreach l [list lib lib_tcl$tclmajorv] {
if {[string tolower [file join $cookbase $l]] ni [string tolower $::auto_path]} {
lappend ::auto_path [file join $cookbase $l]
if {[string tolower [file join $cookbase $l]] ni [list $lc_auto_path {*}$auto_path_additions]} {
lappend auto_path_additions [file join $cookbase $l]
}
}
}
@ -296,9 +314,15 @@ apply { args {
#auto_path - add *external* exe-relative after exe-relative path
#add lib and lib_tcl8 lib_tcl9 etc based on tclmajorv
#libs are appended to end - so add higher priority libraries last (opposite to modules)
#auto_path - add exe-relative after exe-relative path
#libs appended to end of ::auto_path are processed first (reverse order processing in 'package unknown'), but ifneeded scripts are overridden by earlier ones
#(ie for both tcl::tm::list and auto_path it is priority by 'order of appearance' in the resultant lists - not the order in which they are added to the lists)
#
#we can't rely on builtin ledit (tcl9+) or loadable version such as punk::lib::compat::ledit at this point
#so we prepend to auto_path using a slightly inefficient method. Should be fine on relatively small list like this
#eventually it should just be something like 'ledit ::auto_path -1 -1 $libfolder'
if {"windows" eq $::tcl_platform(platform)} {
#case differences dont matter - but can stop us finding path in auto_path
foreach libsub [list lib_tcl$tclmajorv lib] {
@ -307,8 +331,9 @@ apply { args {
} else {
set libfolder $nameexe_dir/$libsub
}
if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
if {[string tolower $libfolder] ni [list {*}$lc_auto_path {*}$auto_path_additions] && [file isdirectory $libfolder]} {
#lappend ::auto_path $libfolder
set auto_path_additions [list $libfolder {*}$auto_path_additions]
}
# -------------
if {[file tail $normexe_dir] eq "bin"} {
@ -316,13 +341,15 @@ apply { args {
} else {
set libfolder $normexe_dir/$libsub
}
if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
if {[string tolower $libfolder] ni [list {*}$lc_auto_path {*}$auto_path_additions] && [file isdirectory $libfolder]} {
#lappend ::auto_path $libfolder
set auto_path_additions [list $libfolder {*}$auto_path_additions]
}
# -------------
set libfolder [pwd]/$libsub
if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
if {[string tolower $libfolder] ni [list {*}$lc_auto_path {*}$auto_path_additions] && [file isdirectory $libfolder]} {
#lappend ::auto_path $libfolder
set auto_path_additions [list $libfolder {*}$auto_path_additions]
}
}
} else {
@ -333,8 +360,9 @@ apply { args {
} else {
set libfolder $nameexe_dir/$libsub
}
if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
if {$libfolder ni [list {*}$::auto_path {*}$auto_path_addtions] && [file isdirectory $libfolder]} {
#lappend ::auto_path $libfolder
set auto_path_additions [list $libfolder {*}$auto_path_additions]
}
# -------------
if {[file tail $normexe_dir] eq "bin"} {
@ -342,16 +370,19 @@ apply { args {
} else {
set libfolder $normexe_dir/$libsub
}
if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
if {$libfolder ni [list {*}$::auto_path {*}$auto_path_additions] && [file isdirectory $libfolder]} {
#lappend ::auto_path $libfolder
set auto_path_additions [list $libfolder {*}$auto_path_additions]
}
# -------------
set libfolder [pwd]/$libsub
if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
if {$libfolder ni [list {*}$::auto_path {*}$auto_path_additions] && [file isdirectory $libfolder]} {
#lappend ::auto_path $libfolder
set auto_path_additions [list $libfolder {*}$auto_path_additions]
}
}
}
set ::auto_path [list {*}$::auto_path {*}$auto_path_additions]
#2) support developer running from a folder containing *.tm files they want to make available
@ -386,18 +417,18 @@ apply { args {
#assert tcl::tm::list still empty here
#restore module paths
#add internals first as in 'dev' mode (dev as first argument on launch) we preference external modules
#tcl::tm::add internals first (so they end up at the end of the tmlist) as in 'dev' mode (dev as first argument on launch) we preference external modules
#note use of lreverse to maintain same order
foreach p [lreverse $internal_tm_dirs] {
if {$p ni [tcl::tm::list]} {
#the prior tm paths go to the head of the list.
#They are processed first.. but an item of same version later in the list will override one at the head. (depending on when list was scanned) REVIEW - true statement???
#Items that end up at the beginning of the tm list are processed first.. but an item of same version later in the tm list will not override the ifneeded script of an already encountered .tm.
#addition can fail if one path is a prefix of another
if {[catch {tcl::tm::add $p} errM]} {
puts stderr "Failed to add internal module dir '$p' to tcl::tm::list\n$errM"
}
}
}
#push externals to *head* of tcl::tm::list - as they have priority
foreach p [lreverse $external_tm_dirs] {
if {$p ni [tcl::tm::list]} {
if {[catch {tcl::tm::add $p} errM]} {
@ -419,19 +450,19 @@ apply { args {
#Tcl_Init will most likely have set up some external paths
#As our app has been started without the 'dev' first arg - we will prune paths that are not zipfs or tclkit
#(or set via punkboot::internal_paths)
set new_auto_path [list]
set filtered_auto_path [list]
#review - case insensitive ok for windows - but could cause issues on other platforms?
foreach ap $::auto_path {
set aplower [string tolower $ap]
foreach okprefix $internal_paths {
if {[string match "[string tolower $okprefix]*" $aplower]} {
lappend new_auto_path $ap
lappend filtered_auto_path $ap
break
}
}
}
set ::auto_path $new_auto_path
#puts stderr "internal_paths: $internal_paths"
puts stderr "main.tcl internal_paths: $internal_paths"
puts stderr "main.tcl filtered_auto_path: $filtered_auto_path"
set new_tm_list [list]
foreach tm [tcl::tm::list] {
@ -463,14 +494,16 @@ apply { args {
#add back the info lib reported by the executable.. as we can't access the one built into a kit
if {[file exists [info library]]} {
lappend ::auto_path [info library]
if {[string tolower [info library]] ni [string tolower [list {*}$filtered_auto_path {*}$auto_path_additions]]} {
lappend auto_path_additions [info library]
}
}
set lib_types [list lib lib_tcl$tclmajorv]
foreach l $lib_types {
set lib [file join $vfsdir $l]
if {[file exists $lib] && [string tolower $lib] ni [string tolower $::auto_path]} {
lappend ::auto_path $lib
if {[file exists $lib] && [string tolower $lib] ni [string tolower [list {*}$filtered_auto_path {*}$auto_path_additions]]} {
lappend auto_path_additions $lib
}
}
#foreach l $lib_types {
@ -479,6 +512,11 @@ apply { args {
# lappend ::auto_path $lib
# }
#}
set ::auto_path [list {*}$filtered_auto_path {*}$auto_path_additions]
puts stderr "main.tcl final auto_path: $::auto_path"
set mod_types [list modules modules_tcl$tclmajorv]
foreach m $mod_types {
set modpath [file join $vfsdir $m]
@ -492,6 +530,9 @@ apply { args {
# tcl::tm::add $modpath
# }
#}
} else {
#normal case main.tcl from vfs
set ::auto_path [list {*}$filtered_auto_path {*}$auto_path_additions]
}
#force rescan
#catch {package require flobrudder666_nonexistant}
@ -499,16 +540,51 @@ apply { args {
}
if {$has_zipfs_attached} {
set zr [::tcl::zipfs::root] ;#always ends with / ? - REVIEW
if {[file join $zr app modules] in [tcl::tm::list]} {
#todo - better way to find latest version - without package require
set lib [file join $zr app modules punk libunknown.tm]
if {[file exists $lib]} {
source $lib
punk::libunknown::init
#package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown}
#load libunknown without triggering the existing package unknown
#maint: also in punk::repl package
#--------------------------------------------------------
set libunks [list]
foreach tm_path [tcl::tm::list] {
set punkdir [file join $tm_path punk]
if {![file exists $punkdir]} {continue}
lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm]
}
set libunknown ""
set libunknown_version_sofar ""
foreach lib $libunks {
#expecting to be of form libunknown-<tclversion>.tm
set vtail [lindex [split [file tail $lib] -] 1]
set thisver [file rootname $vtail] ;#file rootname x.y.z.tm
if {$libunknown_version_sofar eq ""} {
set libunknown_version_sofar $thisver
set libunknown $lib
} else {
if {[package vcompare $thisver $libunknown_version_sofar] == 1} {
set libunknown_version_sofar $thisver
set libunknown $lib
}
}
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller main.tcl} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}
#--------------------------------------------------------
#set zr [::tcl::zipfs::root] ;#always ends with / ? - REVIEW
#if {[file join $zr app modules] in [tcl::tm::list]} {
# #todo - better way to find latest version - without package require
# set lib [file join $zr app modules punk libunknown.tm]
# if {[file exists $lib]} {
# source $lib
# punk::libunknown::init
# #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown}
# }
#}
}
#assert arglist has had 'dev' first arg removed if it was present.

2
src/vfs/_vfscommon.vfs/lib/app-punk/repl.tcl
Unescape View File

@ -34,6 +34,8 @@ set thread_version [package require Thread]
package require shellfilter
package require punk::repl
set v [package provide punk::repl]
puts stderr "punk::repl version:$v script: [package ifneeded punk::repl $v]"
#puts stderr "package names"
#set packages_present [list]
#foreach p [package names] {

37
src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm
Unescape View File

@ -321,6 +321,7 @@ namespace eval argparsingtest {
punk::args::define {
@id -id ::argparsingtest::test1_punkargs2
@cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@leaders -min 0 -max 0
@opts -anyopts 0
-return -default string -type string
-frametype -default \uFFEF -type string
@ -333,10 +334,10 @@ namespace eval argparsingtest {
-1 -default 1 -type boolean
-2 -default 2 -type integer
-3 -default 3 -type integer
@values
@values -min 0 -max 0
}
proc test1_punkargs2 {args} {
set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args]
set argd [punk::args::parse $args withid ::argparsingtest::test1_punkargs2]
return [tcl::dict::get $argd opts]
}
@ -494,6 +495,38 @@ namespace eval argparsingtest {
}]]
return $argd
}
proc test_multiline2 {args} {
set t3 [textblock::frame t3]
set argd [punk::args::parse $args withdef {
-template1 -default {
******
* t1 *
******
}
-template2 -default { ------
******
* t2 *
******}
-template3 -default {$t3}
#substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately
-template3b -default {
${$t3}
-----------------
${$t3}
abc\ndef
}
-template4 -default "******
* t4 *
******"
-template5 -default "
a
${$t3}
c
"
-flag -default 0 -type boolean
}]
return $argd
}
#proc sample1 {p1 n args} {
# #*** !doctools

202
src/vfs/_vfscommon.vfs/modules/punk-0.1.tm
Unescape View File

@ -515,6 +515,7 @@ namespace eval punk {
#proc ::objclone {obj} {
# append obj2 $obj {}
#}
#-----------------------------------------------------------------------------------
#order of arguments designed for pipelining
#review - 'piper_' prefix is a naming convention for functions that are ordered for tail-argument pipelining
@ -530,6 +531,152 @@ namespace eval punk {
proc ::punk::K {x y} { return $x}
#todo ansigrep? e.g grep using ansistripped value
proc grepstr1 {pattern data} {
set data [string map {\r\n \n} $data]
set lines [split $data \n]
set matches [lsearch -all -regexp $lines $pattern]
set max [lindex $matches end]
set w1 [string length $max]
set result ""
set H [a+ green bold overline]
set R \x1b\[m
foreach m $matches {
set ln [lindex $lines $m]
set ln [regsub -all $pattern $ln $H&$R]
append result [format %${w1}s $m] " $ln" \n
}
set result [string trimright $result \n]
return $result
}
#----------------------
#todo - fix overtype
#create test
#overtype::renderline -insert_mode 0 -transparent 1 [a+ green]-----[a] " [a+ underline]x[a]"
#----------------------
punk::args::define {
@id -id ::punk::grepstr
@cmd -name punk::grepstr\
-summary\
"Grep for regex pattern in supplied (possibly ANSI) string."\
-help\
""
@leaders -min 0 -max 0
@opts
-returnlines -type string -default all -choices {matched all}
-ansistrip -type none
-no-linenumbers -type none
-highlight -type list -typesynopsis ansinames -default {green bold Black underline overline} -help\
"list of ANSI SGR style codes as supported by and documented in punk::ansi::a?"
-- -type none
@values
pattern -type string -help\
"regex pattern to match in plaintext portion of ANSI string"
string -type string
}
proc grepstr {args} {
lassign [dict values [punk::args::parse $args withid ::punk::grepstr]] leaders opts values received
set pattern [dict get $values pattern]
set data [dict get $values string]
set do_strip 0
if {[dict exists $received -ansistrip]} {
set data [punk::ansi::ansistrip $data]
}
set highlight [dict get $opts -highlight]
set returnlines [dict get $opts -returnlines]
if {[dict exists $received -no-linenumbers]} {
set do_linenums 0
} else {
set do_linenums 1
}
if {[llength $highlight] == 0} {
set H ""
set R ""
} else {
set H [a+ {*}$highlight]
set R \x1b\[m
}
set data [string map {\r\n \n} $data]
if {![punk::ansi::ta::detect $data]} {
set lines [split $data \n]
set matches [lsearch -all -regexp $lines $pattern]
set result ""
if {$returnlines eq "all"} {
set returnlines [punk::lib::range 0 [llength $lines]-1]
} else {
set returnlines $matches
}
set max [lindex $returnlines end]
set w1 [string length $max]
foreach linenum $returnlines {
if {$do_linenums} {
set col1 "[format %${w1}s $linenum] "
} else {
set col1 ""
}
set ln [lindex $lines $linenum]
if {$linenum in $matches} {
set ln [regsub -all -- $pattern $ln $H&$R]
}
append result $col1 $ln \n
}
set result [string trimright $result \n]
return $result
} else {
set plain [punk::ansi::ansistrip $data]
set plainlines [split $plain \n]
set lines [split $data \n]
set matches [lsearch -all -regexp $plainlines $pattern]
if {$returnlines eq "all"} {
set returnlines [punk::lib::range 0 [llength $lines]-1]
} else {
set returnlines $matches
}
set max [lindex $returnlines end]
set w1 [string length $max]
set result ""
set placeholder \UFFEF ;#review
foreach linenum $returnlines {
set ln [lindex $lines $linenum]
if {$do_linenums} {
set col1 "[format %${w1}s $linenum] "
} else {
set col1 ""
}
if {$linenum in $matches} {
set plain_ln [lindex $plainlines $linenum]
set parts [regexp -all -indices -inline -- $pattern $plain_ln]
if {[llength $parts] == 0} {
#shouldn't happen
append result $col1 $ln \n
} else {
set overlay ""
set i 0
foreach prange $parts {
lassign $prange s e
set prelen [expr {$s - $i}]
append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]$R
set i [expr {$e + 1}]
}
set tail [string range $plain_ln $e+1 end]
append overlay [string repeat $placeholder [string length $tail]]
#puts "$overlay"
#puts "$ln"
append result $col1 [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay] \n
}
} else {
append result $col1 $ln \n
}
}
return $result
}
}
proc stacktrace {} {
set stack "Stack trace:\n"
for {set i 1} {$i < [info level]} {incr i} {
@ -6803,9 +6950,18 @@ namespace eval punk {
punk::args::define {
@dynamic
@id -id ::punk::LOC
@cmd -name punk::LOC -help\
@cmd -name punk::LOC\
-summary\
"Lines Of Code counter"\
-help\
"LOC - lines of code.
An implementation of a notoriously controversial metric"
An implementation of a notoriously controversial metric.
Returns a dict or dictionary-display containing various
counts such as:
'loc' - total lines of code.
'purepunctuationlines' - lines consisting soley of punctuation.
'filecount' - number of files examined."
@opts
-return -default showdict -choices {dict showdict}
-dir -default "\uFFFF"
-exclude_dupfiles -default 1 -type boolean
@ -6820,13 +6976,18 @@ namespace eval punk {
} "
#we could map away whitespace and use string is punct - but not as flexible? review
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
"
" {
@values
fileglob -type string -default * -optional 1 -multiple 1 -help\
"glob patterns to match against the filename portion (last segment) of each
file path. e.g *.tcl *.tm"
}
}
#An implementation of a notoriously controversial metric.
proc LOC {args} {
set argd [punk::args::parse $args withid ::punk::LOC]
lassign [dict values $argd] leaders opts values received
set searchspecs [dict values $values]
set searchspecs [dict get $values fileglob]
# -- --- --- --- --- ---
set opt_return [dict get $opts -return]
@ -7344,6 +7505,7 @@ namespace eval punk {
set cmdinfo [list]
lappend cmdinfo [list help "?topics?" "This help. To see available subitems type: help topics"]
lappend cmdinfo [list i "cmd ?subcommand...?" "Show usage for a command or ensemble subcommand"]
lappend cmdinfo [list s "cmd ?subcommand...?" "Show synopsis for a command or ensemble subcommand"]
lappend cmdinfo [list ./ "?subdir?" "view/change directory"]
lappend cmdinfo [list ../ "" "go up one directory"]
lappend cmdinfo [list ./new "subdir" "make new directory and switch to it"]
@ -7495,27 +7657,33 @@ namespace eval punk {
set indent [string repeat " " [string length "WARNING: "]]
lappend cstring_tests [dict create\
type "PM "\
msg "PRIVACY MESSAGE"\
msg "UN"\
f7 punk::ansi::controlstring_PM\
f7desc "7bit ESC ^"\
f7prefix "7bit ESC ^ secret "\
f7suffix "safe"\
f8 punk::ansi::controlstring_PM8\
f8desc "8bit \\x9e"\
f8prefix "8bit \\x9e secret "\
f8suffix "safe"\
]
lappend cstring_tests [dict create\
type SOS\
msg "STRING"\
msg "NOT"\
f7 punk::ansi::controlstring_SOS\
f7desc "7bit ESC X"\
f7prefix "7bit ESC X string "\
f7suffix " hidden"\
f8 punk::ansi::controlstring_SOS8\
f8desc "8bit \\x98"\
f8prefix "8bit \\x98 string "\
f8suffix " hidden"\
]
lappend cstring_tests [dict create\
type APC\
msg "APPLICATION PROGRAM COMMAND"\
msg "NOT"\
f7 punk::ansi::controlstring_APC\
f7desc "7bit ESC _"\
f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\
f7suffix " hidden"\
f8 punk::ansi::controlstring_APC8\
f8desc "8bit \\x9f"\
f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\
f8suffix " hidden"\
]
foreach test $cstring_tests {
@ -7525,14 +7693,14 @@ namespace eval punk {
set hidden_width_m8 [punk::console::test_char_width $m8]
if {$hidden_width_m != 0 || $hidden_width_m8 != 0} {
if {$hidden_width_m == 0} {
set d "[a+ green bold][dict get $test f7desc] [a red]${m}[a]"
set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]"
} else {
set d "[a+ yellow bold][dict get $test f7desc] [a red]$m[a]"
set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]"
}
if {$hidden_width_m8 == 0} {
set d8 "[a+ green ][dict get $test f8desc] [a red]$m8[a]"
set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]"
} else {
set d8 "[a+ yellow bold][dict get $test f8desc] [a red]$m8[a]"
set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]"
}
append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8"
}

2
src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm
Unescape View File

@ -118,6 +118,7 @@ tcl::namespace::eval punk::aliascore {
pdict ::punk::lib::pdict\
plist {::punk::lib::pdict -roottype list}\
showlist {::punk::lib::showdict -roottype list}\
grepstr ::punk::grepstr\
rehash ::punk::rehash\
showdict ::punk::lib::showdict\
ansistrip ::punk::ansi::ansistrip\
@ -136,6 +137,7 @@ tcl::namespace::eval punk::aliascore {
rmcup ::punk::console::disable_alt_screen\
config ::punk::config\
s ::punk::ns::synopsis\
eg ::punk::ns::eg\
]
#*** !doctools

977
src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm
View File

File diff suppressed because it is too large Load Diff

969
src/vfs/_vfscommon.vfs/modules/punk/ansi/colourmap-0.1.0.tm
Unescape View File

@ -0,0 +1,969 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# 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) 2025
#
# @@ Meta Begin
# Application ::punk::ansi::colourmap 0.1.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_::punk::ansi::colourmap 0 0.1.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require ::punk::ansi::colourmap]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of ::punk::ansi::colourmap
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by ::punk::ansi::colourmap
#[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]
tcl::namespace::eval ::punk::ansi::colourmap {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection {Namespace ::punk::ansi::colourmap}]
#[para] Core API functions for ::punk::ansi::colourmap
#[list_begin definitions]
variable PUNKARGS
#----------------------------------------------
#todo - document vars as part of package API
#- or provide a function to return varnames?
#- or wrap each in a function and see if any performance/memory impact? (readonly - so should just be a reference without any copying?)
#TK_colour_map
#TK_colour_map_lookup
#TK_colour_map_merge
#TK_colour_map_reverse
#----------------------------------------------
#significantly slower than tables - but here as a check/test
lappend PUNKARGS [list {
@id -id ::punk::ansi::colourmap::get_rgb_using_tk
@cmd -name punk::ansi::colourmap::get_rgb_using_tk -help\
"This function requires Tk to function, and will call
'package require tk' to load it.
The name argument accepts Tk colour names or hex values
in either #XXX or #XXXXXX format.
Tk colour names can be displayed using the command:
punk::ansi::a? tk ?glob..?
get_rgb_using_tk returns a decimal rgb string delimited with dashes.
e.g
get_rgb_using_tk #FFF
255-255-255
get_rgb_using_tk SlateBlue
106-90-205"
@leaders
name -type string|stringstartswith(#)
}]
proc get_rgb_using_tk {name} {
package require tk
#assuming 'winfo depth .' is always 32 ?
set RGB [winfo rgb . $name]
set rgb [lmap n $RGB {expr {$n / 256}}]
return [join $rgb -]
}
variable TK_colour_map
tcl::dict::set TK_colour_map "alice blue" 240-248-255
tcl::dict::set TK_colour_map AliceBlue 240-248-255
tcl::dict::set TK_colour_map "antique white" 250-235-215
tcl::dict::set TK_colour_map AntiqueWhite 250-235-215
tcl::dict::set TK_colour_map AntiqueWhite1 255-239-219
tcl::dict::set TK_colour_map AntiqueWhite2 238-223-204
tcl::dict::set TK_colour_map AntiqueWhite3 205-192-176
tcl::dict::set TK_colour_map AntiqueWhite4 139-131-120
tcl::dict::set TK_colour_map aqua 0-255-255
tcl::dict::set TK_colour_map aquamarine 127-255-212
tcl::dict::set TK_colour_map aquamarine1 127-255-212
tcl::dict::set TK_colour_map aquamarine2 118-238-198
tcl::dict::set TK_colour_map aquamarine3 102-205-170
tcl::dict::set TK_colour_map aquamarine4 69-139-16
tcl::dict::set TK_colour_map azure 240-255-255
tcl::dict::set TK_colour_map azure1 240-255-255
tcl::dict::set TK_colour_map azure2 224-238-238
tcl::dict::set TK_colour_map azure3 193-205-205
tcl::dict::set TK_colour_map azure4 131-139-139
tcl::dict::set TK_colour_map beige 245-245-220
tcl::dict::set TK_colour_map bisque 255-228-196
tcl::dict::set TK_colour_map bisque1 255-228-196
tcl::dict::set TK_colour_map bisque2 238-213-183
tcl::dict::set TK_colour_map bisque3 205-183-158
tcl::dict::set TK_colour_map bisque4 139-125-107
tcl::dict::set TK_colour_map black 0-0-0
tcl::dict::set TK_colour_map "blanched almond" 255-235-205
tcl::dict::set TK_colour_map BlanchedAlmond 255-235-205
tcl::dict::set TK_colour_map blue 0-0-255
tcl::dict::set TK_colour_map "blue violet" 138-43-226
tcl::dict::set TK_colour_map blue1 0-0-255
tcl::dict::set TK_colour_map blue2 0-0-238
tcl::dict::set TK_colour_map blue3 0-0-205
tcl::dict::set TK_colour_map blue4 0-0-139
tcl::dict::set TK_colour_map BlueViolet 138-43-226
tcl::dict::set TK_colour_map brown 165-42-42
tcl::dict::set TK_colour_map brown1 255-64-64
tcl::dict::set TK_colour_map brown2 238-59-59
tcl::dict::set TK_colour_map brown3 205-51-51
tcl::dict::set TK_colour_map brown4 139-35-35
tcl::dict::set TK_colour_map burlywood 222-184-135
tcl::dict::set TK_colour_map burlywood1 255-211-155
tcl::dict::set TK_colour_map burlywood2 238-197-145
tcl::dict::set TK_colour_map burlywood3 205-170-125
tcl::dict::set TK_colour_map burlywood4 139-115-85
tcl::dict::set TK_colour_map "cadet blue" 95-158-160
tcl::dict::set TK_colour_map CadetBlue 95-158-160
tcl::dict::set TK_colour_map CadetBlue1 152-245-255
tcl::dict::set TK_colour_map CadetBlue2 142-229-238
tcl::dict::set TK_colour_map CadetBlue3 122-197-205
tcl::dict::set TK_colour_map CadetBlue4 83-134-139
tcl::dict::set TK_colour_map chartreuse 127-255-0
tcl::dict::set TK_colour_map chartreuse1 127-255-0
tcl::dict::set TK_colour_map chartreuse2 118-238-0
tcl::dict::set TK_colour_map chartreuse3 102-205-0
tcl::dict::set TK_colour_map chartreuse4 69-139-0
tcl::dict::set TK_colour_map chocolate 210-105-30
tcl::dict::set TK_colour_map chocolate1 255-127-36
tcl::dict::set TK_colour_map chocolate2 238-118-33
tcl::dict::set TK_colour_map chocolate3 205-102-29
tcl::dict::set TK_colour_map chocolate4 139-69-19
tcl::dict::set TK_colour_map coral 255-127-80
tcl::dict::set TK_colour_map coral1 255-114-86
tcl::dict::set TK_colour_map coral2 238-106-80
tcl::dict::set TK_colour_map coral3 205-91-69
tcl::dict::set TK_colour_map coral4 139-62-47
tcl::dict::set TK_colour_map "cornflower blue" 100-149-237
tcl::dict::set TK_colour_map CornflowerBlue 100-149-237
tcl::dict::set TK_colour_map cornsilk 255-248-220
tcl::dict::set TK_colour_map cornsilk1 255-248-220
tcl::dict::set TK_colour_map cornsilk2 238-232-205
tcl::dict::set TK_colour_map cornsilk3 205-200-177
tcl::dict::set TK_colour_map cornsilk4 139-136-120
tcl::dict::set TK_colour_map crimson 220-20-60
tcl::dict::set TK_colour_map cyan 0-255-255
tcl::dict::set TK_colour_map cyan1 0-255-255
tcl::dict::set TK_colour_map cyan2 0-238-238
tcl::dict::set TK_colour_map cyan3 0-205-205
tcl::dict::set TK_colour_map cyan4 0-139-139
tcl::dict::set TK_colour_map "dark blue" 0-0-139
tcl::dict::set TK_colour_map "dark cyan" 0-139-139
tcl::dict::set TK_colour_map "dark goldenrod" 184-134-11
tcl::dict::set TK_colour_map "dark gray" 169-169-169
tcl::dict::set TK_colour_map "dark green" 0-100-0
tcl::dict::set TK_colour_map "dark grey" 169-169-169
tcl::dict::set TK_colour_map "dark khaki" 189-183-107
tcl::dict::set TK_colour_map "dark magenta" 139-0-139
tcl::dict::set TK_colour_map "dark olive green" 85-107-47
tcl::dict::set TK_colour_map "dark orange" 255-140-0
tcl::dict::set TK_colour_map "dark orchid" 153-50-204
tcl::dict::set TK_colour_map "dark red" 139-0-0
tcl::dict::set TK_colour_map "dark salmon" 233-150-122
tcl::dict::set TK_colour_map "dark sea green" 143-188-143
tcl::dict::set TK_colour_map "dark slate blue" 72-61-139
tcl::dict::set TK_colour_map "dark slate gray" 47-79-79
tcl::dict::set TK_colour_map "dark slate grey" 47-79-79
tcl::dict::set TK_colour_map "dark turquoise" 0-206-209
tcl::dict::set TK_colour_map "dark violet" 148-0-211
tcl::dict::set TK_colour_map DarkBlue 0-0-139
tcl::dict::set TK_colour_map DarkCyan 0-139-139
tcl::dict::set TK_colour_map DarkGoldenrod 184-134-11
tcl::dict::set TK_colour_map DarkGoldenrod1 255-185-15
tcl::dict::set TK_colour_map DarkGoldenrod2 238-173-14
tcl::dict::set TK_colour_map DarkGoldenrod3 205-149-12
tcl::dict::set TK_colour_map DarkGoldenrod4 139-101-8
tcl::dict::set TK_colour_map DarkGray 169-169-169
tcl::dict::set TK_colour_map DarkGreen 0-100-0
tcl::dict::set TK_colour_map DarkGrey 169-169-169
tcl::dict::set TK_colour_map DarkKhaki 189-183-107
tcl::dict::set TK_colour_map DarkMagenta 139-0-139
tcl::dict::set TK_colour_map DarkOliveGreen 85-107-47
tcl::dict::set TK_colour_map DarkOliveGreen1 202-255-112
tcl::dict::set TK_colour_map DarkOliveGreen2 188-238-104
tcl::dict::set TK_colour_map DarkOliveGreen3 162-205-90
tcl::dict::set TK_colour_map DarkOliveGreen4 110-139-61
tcl::dict::set TK_colour_map DarkOrange 255-140-0
tcl::dict::set TK_colour_map DarkOrange1 255-127-0
tcl::dict::set TK_colour_map DarkOrange2 238-118-0
tcl::dict::set TK_colour_map DarkOrange3 205-102-0
tcl::dict::set TK_colour_map DarkOrange4 139-69-0
tcl::dict::set TK_colour_map DarkOrchid 153-50-204
tcl::dict::set TK_colour_map DarkOrchid1 191-62-255
tcl::dict::set TK_colour_map DarkOrchid2 178-58-238
tcl::dict::set TK_colour_map DarkOrchid3 154-50-205
tcl::dict::set TK_colour_map DarkOrchid4 104-34-139
tcl::dict::set TK_colour_map DarkRed 139-0-0
tcl::dict::set TK_colour_map DarkSalmon 233-150-122
tcl::dict::set TK_colour_map DarkSeaGreen 43-188-143
tcl::dict::set TK_colour_map DarkSeaGreen1 193-255-193
tcl::dict::set TK_colour_map DarkSeaGreen2 180-238-180
tcl::dict::set TK_colour_map DarkSeaGreen3 155-205-155
tcl::dict::set TK_colour_map DarkSeaGreen4 105-139-105
tcl::dict::set TK_colour_map DarkSlateBlue 72-61-139
tcl::dict::set TK_colour_map DarkSlateGray 47-79-79
tcl::dict::set TK_colour_map DarkSlateGray1 151-255-255
tcl::dict::set TK_colour_map DarkSlateGray2 141-238-238
tcl::dict::set TK_colour_map DarkSlateGray3 121-205-205
tcl::dict::set TK_colour_map DarkSlateGray4 82-139-139
tcl::dict::set TK_colour_map DarkSlateGrey 47-79-79
tcl::dict::set TK_colour_map DarkTurquoise 0-206-209
tcl::dict::set TK_colour_map DarkViolet 148-0-211
tcl::dict::set TK_colour_map "deep pink" 255-20-147
tcl::dict::set TK_colour_map "deep sky blue" 0-191-255
tcl::dict::set TK_colour_map DeepPink 255-20-147
tcl::dict::set TK_colour_map DeepPink1 255-20-147
tcl::dict::set TK_colour_map DeepPink2 238-18-137
tcl::dict::set TK_colour_map DeepPink3 205-16-118
tcl::dict::set TK_colour_map DeepPink4 139-10-80
tcl::dict::set TK_colour_map DeepSkyBlue 0-191-255
tcl::dict::set TK_colour_map DeepSkyBlue1 0-191-255
tcl::dict::set TK_colour_map DeepSkyBlue2 0-178-238
tcl::dict::set TK_colour_map DeepSkyBlue3 0-154-205
tcl::dict::set TK_colour_map DeepSkyBlue4 0-104-139
tcl::dict::set TK_colour_map "dim gray" 105-105-105
tcl::dict::set TK_colour_map "dim grey" 105-105-105
tcl::dict::set TK_colour_map DimGray 105-105-105
tcl::dict::set TK_colour_map DimGrey 105-105-105
tcl::dict::set TK_colour_map "dodger blue" 30-144-255
tcl::dict::set TK_colour_map DodgerBlue 30-144-255
tcl::dict::set TK_colour_map DodgerBlue1 30-144-255
tcl::dict::set TK_colour_map DodgerBlue2 28-134-238
tcl::dict::set TK_colour_map DodgerBlue3 24-116-205
tcl::dict::set TK_colour_map DodgerBlue4 16-78-139
tcl::dict::set TK_colour_map firebrick 178-34-34
tcl::dict::set TK_colour_map firebrick1 255-48-48
tcl::dict::set TK_colour_map firebrick2 238-44-44
tcl::dict::set TK_colour_map firebrick3 205-38-38
tcl::dict::set TK_colour_map firebrick4 139-26-26
tcl::dict::set TK_colour_map "floral white" 255-250-240
tcl::dict::set TK_colour_map FloralWhite 255-250-240
tcl::dict::set TK_colour_map "forest green" 34-139-34
tcl::dict::set TK_colour_map ForestGreen 34-139-34
tcl::dict::set TK_colour_map fuchsia 255-0-255
tcl::dict::set TK_colour_map gainsboro 220-220-220
tcl::dict::set TK_colour_map "ghost white" 248-248-255
tcl::dict::set TK_colour_map GhostWhite 248-248-255
tcl::dict::set TK_colour_map gold 255-215-0
tcl::dict::set TK_colour_map gold1 255-215-0
tcl::dict::set TK_colour_map gold2 238-201-0
tcl::dict::set TK_colour_map gold3 205-173-0
tcl::dict::set TK_colour_map gold4 139-117-0
tcl::dict::set TK_colour_map goldenrod 218-165-32
tcl::dict::set TK_colour_map goldenrod1 255-193-37
tcl::dict::set TK_colour_map goldenrod2 238-180-34
tcl::dict::set TK_colour_map goldenrod3 205-155-29
tcl::dict::set TK_colour_map goldenrod4 139-105-20
tcl::dict::set TK_colour_map gray 128-128-128
tcl::dict::set TK_colour_map gray0 0-0-0
tcl::dict::set TK_colour_map gray1 3-3-3
tcl::dict::set TK_colour_map gray2 5-5-5
tcl::dict::set TK_colour_map gray3 8-8-8
tcl::dict::set TK_colour_map gray4 10-10-10
tcl::dict::set TK_colour_map gray5 13-13-13
tcl::dict::set TK_colour_map gray6 15-15-15
tcl::dict::set TK_colour_map gray7 18-18-18
tcl::dict::set TK_colour_map gray8 20-20-20
tcl::dict::set TK_colour_map gray9 23-23-23
tcl::dict::set TK_colour_map gray10 26-26-26
tcl::dict::set TK_colour_map gray11 28-28-28
tcl::dict::set TK_colour_map gray12 31-31-31
tcl::dict::set TK_colour_map gray13 33-33-33
tcl::dict::set TK_colour_map gray14 36-36-36
tcl::dict::set TK_colour_map gray15 38-38-38
tcl::dict::set TK_colour_map gray16 41-41-41
tcl::dict::set TK_colour_map gray17 43-43-43
tcl::dict::set TK_colour_map gray18 46-46-46
tcl::dict::set TK_colour_map gray19 48-48-48
tcl::dict::set TK_colour_map gray20 51-51-51
tcl::dict::set TK_colour_map gray21 54-54-54
tcl::dict::set TK_colour_map gray22 56-56-56
tcl::dict::set TK_colour_map gray23 59-59-59
tcl::dict::set TK_colour_map gray24 61-61-61
tcl::dict::set TK_colour_map gray25 64-64-64
tcl::dict::set TK_colour_map gray26 66-66-66
tcl::dict::set TK_colour_map gray27 69-69-69
tcl::dict::set TK_colour_map gray28 71-71-71
tcl::dict::set TK_colour_map gray29 74-74-74
tcl::dict::set TK_colour_map gray30 77-77-77
tcl::dict::set TK_colour_map gray31 79-79-79
tcl::dict::set TK_colour_map gray32 82-82-82
tcl::dict::set TK_colour_map gray33 84-84-84
tcl::dict::set TK_colour_map gray34 87-87-87
tcl::dict::set TK_colour_map gray35 89-89-89
tcl::dict::set TK_colour_map gray36 92-92-92
tcl::dict::set TK_colour_map gray37 94-94-94
tcl::dict::set TK_colour_map gray38 97-97-97
tcl::dict::set TK_colour_map gray39 99-99-99
tcl::dict::set TK_colour_map gray40 102-102-102
tcl::dict::set TK_colour_map gray41 105-105-105
tcl::dict::set TK_colour_map gray42 107-107-107
tcl::dict::set TK_colour_map gray43 110-110-110
tcl::dict::set TK_colour_map gray44 112-112-112
tcl::dict::set TK_colour_map gray45 115-115-115
tcl::dict::set TK_colour_map gray46 117-117-117
tcl::dict::set TK_colour_map gray47 120-120-120
tcl::dict::set TK_colour_map gray48 122-122-122
tcl::dict::set TK_colour_map gray49 125-125-125
tcl::dict::set TK_colour_map gray50 127-127-127
tcl::dict::set TK_colour_map gray51 130-130-130
tcl::dict::set TK_colour_map gray52 133-133-133
tcl::dict::set TK_colour_map gray53 135-135-135
tcl::dict::set TK_colour_map gray54 138-138-138
tcl::dict::set TK_colour_map gray55 140-140-140
tcl::dict::set TK_colour_map gray56 143-143-143
tcl::dict::set TK_colour_map gray57 145-145-145
tcl::dict::set TK_colour_map gray58 148-148-148
tcl::dict::set TK_colour_map gray59 150-150-150
tcl::dict::set TK_colour_map gray60 153-153-153
tcl::dict::set TK_colour_map gray61 156-156-156
tcl::dict::set TK_colour_map gray62 158-158-158
tcl::dict::set TK_colour_map gray63 161-161-161
tcl::dict::set TK_colour_map gray64 163-163-163
tcl::dict::set TK_colour_map gray65 166-166-166
tcl::dict::set TK_colour_map gray66 168-168-168
tcl::dict::set TK_colour_map gray67 171-171-171
tcl::dict::set TK_colour_map gray68 173-173-173
tcl::dict::set TK_colour_map gray69 176-176-176
tcl::dict::set TK_colour_map gray70 179-179-179
tcl::dict::set TK_colour_map gray71 181-181-181
tcl::dict::set TK_colour_map gray72 184-184-184
tcl::dict::set TK_colour_map gray73 186-186-186
tcl::dict::set TK_colour_map gray74 189-189-189
tcl::dict::set TK_colour_map gray75 191-191-191
tcl::dict::set TK_colour_map gray76 194-194-194
tcl::dict::set TK_colour_map gray77 196-196-196
tcl::dict::set TK_colour_map gray78 199-199-199
tcl::dict::set TK_colour_map gray79 201-201-201
tcl::dict::set TK_colour_map gray80 204-204-204
tcl::dict::set TK_colour_map gray81 207-207-207
tcl::dict::set TK_colour_map gray82 209-209-209
tcl::dict::set TK_colour_map gray83 212-212-212
tcl::dict::set TK_colour_map gray84 214-214-214
tcl::dict::set TK_colour_map gray85 217-217-217
tcl::dict::set TK_colour_map gray86 219-219-219
tcl::dict::set TK_colour_map gray87 222-222-222
tcl::dict::set TK_colour_map gray88 224-224-224
tcl::dict::set TK_colour_map gray89 227-227-227
tcl::dict::set TK_colour_map gray90 229-229-229
tcl::dict::set TK_colour_map gray91 232-232-232
tcl::dict::set TK_colour_map gray92 235-235-235
tcl::dict::set TK_colour_map gray93 237-237-237
tcl::dict::set TK_colour_map gray94 240-240-240
tcl::dict::set TK_colour_map gray95 242-242-242
tcl::dict::set TK_colour_map gray96 245-245-245
tcl::dict::set TK_colour_map gray97 247-247-247
tcl::dict::set TK_colour_map gray98 250-250-250
tcl::dict::set TK_colour_map gray99 252-252-252
tcl::dict::set TK_colour_map gray100 255-255-255
tcl::dict::set TK_colour_map green 0-128-0
tcl::dict::set TK_colour_map "green yellow" 173-255-47
tcl::dict::set TK_colour_map green1 0-255-0
tcl::dict::set TK_colour_map green2 0-238-0
tcl::dict::set TK_colour_map green3 0-205-0
tcl::dict::set TK_colour_map green4 0-139-0
tcl::dict::set TK_colour_map GreenYellow 173-255-47
tcl::dict::set TK_colour_map grey 128-128-128
tcl::dict::set TK_colour_map grey0 0-0-0
tcl::dict::set TK_colour_map grey1 3-3-3
tcl::dict::set TK_colour_map grey2 5-5-5
tcl::dict::set TK_colour_map grey3 8-8-8
tcl::dict::set TK_colour_map grey4 10-10-10
tcl::dict::set TK_colour_map grey5 13-13-13
tcl::dict::set TK_colour_map grey6 15-15-15
tcl::dict::set TK_colour_map grey7 18-18-18
tcl::dict::set TK_colour_map grey8 20-20-20
tcl::dict::set TK_colour_map grey9 23-23-23
tcl::dict::set TK_colour_map grey10 26-26-26
tcl::dict::set TK_colour_map grey11 28-28-28
tcl::dict::set TK_colour_map grey12 31-31-31
tcl::dict::set TK_colour_map grey13 33-33-33
tcl::dict::set TK_colour_map grey14 36-36-36
tcl::dict::set TK_colour_map grey15 38-38-38
tcl::dict::set TK_colour_map grey16 41-41-41
tcl::dict::set TK_colour_map grey17 43-43-43
tcl::dict::set TK_colour_map grey18 46-46-46
tcl::dict::set TK_colour_map grey19 48-48-48
tcl::dict::set TK_colour_map grey20 51-51-51
tcl::dict::set TK_colour_map grey21 54-54-54
tcl::dict::set TK_colour_map grey22 56-56-56
tcl::dict::set TK_colour_map grey23 59-59-59
tcl::dict::set TK_colour_map grey24 61-61-61
tcl::dict::set TK_colour_map grey25 64-64-64
tcl::dict::set TK_colour_map grey26 66-66-66
tcl::dict::set TK_colour_map grey27 69-69-69
tcl::dict::set TK_colour_map grey28 71-71-71
tcl::dict::set TK_colour_map grey29 74-74-74
tcl::dict::set TK_colour_map grey30 77-77-77
tcl::dict::set TK_colour_map grey31 79-79-79
tcl::dict::set TK_colour_map grey32 82-82-82
tcl::dict::set TK_colour_map grey33 84-84-84
tcl::dict::set TK_colour_map grey34 87-87-87
tcl::dict::set TK_colour_map grey35 89-89-89
tcl::dict::set TK_colour_map grey36 92-92-92
tcl::dict::set TK_colour_map grey37 94-94-94
tcl::dict::set TK_colour_map grey38 97-97-97
tcl::dict::set TK_colour_map grey39 99-99-99
tcl::dict::set TK_colour_map grey40 102-102-102
tcl::dict::set TK_colour_map grey41 105-105-105
tcl::dict::set TK_colour_map grey42 107-107-107
tcl::dict::set TK_colour_map grey43 110-110-110
tcl::dict::set TK_colour_map grey44 112-112-112
tcl::dict::set TK_colour_map grey45 115-115-115
tcl::dict::set TK_colour_map grey46 117-117-117
tcl::dict::set TK_colour_map grey47 120-120-120
tcl::dict::set TK_colour_map grey48 122-122-122
tcl::dict::set TK_colour_map grey49 125-125-125
tcl::dict::set TK_colour_map grey50 127-127-127
tcl::dict::set TK_colour_map grey51 130-130-130
tcl::dict::set TK_colour_map grey52 133-133-133
tcl::dict::set TK_colour_map grey53 135-135-135
tcl::dict::set TK_colour_map grey54 138-138-138
tcl::dict::set TK_colour_map grey55 140-140-140
tcl::dict::set TK_colour_map grey56 143-143-143
tcl::dict::set TK_colour_map grey57 145-145-145
tcl::dict::set TK_colour_map grey58 148-148-148
tcl::dict::set TK_colour_map grey59 150-150-150
tcl::dict::set TK_colour_map grey60 153-153-153
tcl::dict::set TK_colour_map grey61 156-156-156
tcl::dict::set TK_colour_map grey62 158-158-158
tcl::dict::set TK_colour_map grey63 161-161-161
tcl::dict::set TK_colour_map grey64 163-163-163
tcl::dict::set TK_colour_map grey65 166-166-166
tcl::dict::set TK_colour_map grey66 168-168-168
tcl::dict::set TK_colour_map grey67 171-171-171
tcl::dict::set TK_colour_map grey68 173-173-173
tcl::dict::set TK_colour_map grey69 176-176-176
tcl::dict::set TK_colour_map grey70 179-179-179
tcl::dict::set TK_colour_map grey71 181-181-181
tcl::dict::set TK_colour_map grey72 184-184-184
tcl::dict::set TK_colour_map grey73 186-186-186
tcl::dict::set TK_colour_map grey74 189-189-189
tcl::dict::set TK_colour_map grey75 191-191-191
tcl::dict::set TK_colour_map grey76 194-194-194
tcl::dict::set TK_colour_map grey77 196-196-196
tcl::dict::set TK_colour_map grey78 199-199-199
tcl::dict::set TK_colour_map grey79 201-201-201
tcl::dict::set TK_colour_map grey80 204-204-204
tcl::dict::set TK_colour_map grey81 207-207-207
tcl::dict::set TK_colour_map grey82 209-209-209
tcl::dict::set TK_colour_map grey83 212-212-212
tcl::dict::set TK_colour_map grey84 214-214-214
tcl::dict::set TK_colour_map grey85 217-217-217
tcl::dict::set TK_colour_map grey86 219-219-219
tcl::dict::set TK_colour_map grey87 222-222-222
tcl::dict::set TK_colour_map grey88 224-224-224
tcl::dict::set TK_colour_map grey89 227-227-227
tcl::dict::set TK_colour_map grey90 229-229-229
tcl::dict::set TK_colour_map grey91 232-232-232
tcl::dict::set TK_colour_map grey92 235-235-235
tcl::dict::set TK_colour_map grey93 237-237-237
tcl::dict::set TK_colour_map grey94 240-240-240
tcl::dict::set TK_colour_map grey95 242-242-242
tcl::dict::set TK_colour_map grey96 245-245-245
tcl::dict::set TK_colour_map grey97 247-247-247
tcl::dict::set TK_colour_map grey98 250-250-250
tcl::dict::set TK_colour_map grey99 252-252-252
tcl::dict::set TK_colour_map grey100 255-255-255
tcl::dict::set TK_colour_map honeydew 240-255-240
tcl::dict::set TK_colour_map honeydew1 240-255-240
tcl::dict::set TK_colour_map honeydew2 224-238-224
tcl::dict::set TK_colour_map honeydew3 193-205-193
tcl::dict::set TK_colour_map honeydew4 131-139-131
tcl::dict::set TK_colour_map "hot pink" 255-105-180
tcl::dict::set TK_colour_map HotPink 255-105-180
tcl::dict::set TK_colour_map HotPink1 255-110-180
tcl::dict::set TK_colour_map HotPink2 238-106-167
tcl::dict::set TK_colour_map HotPink3 205-96-144
tcl::dict::set TK_colour_map HotPink4 139-58-98
tcl::dict::set TK_colour_map "indian red" 205-92-92
tcl::dict::set TK_colour_map IndianRed 205-92-92
tcl::dict::set TK_colour_map IndianRed1 255-106-106
tcl::dict::set TK_colour_map IndianRed2 238-99-99
tcl::dict::set TK_colour_map IndianRed3 205-85-85
tcl::dict::set TK_colour_map IndianRed4 139-58-58
tcl::dict::set TK_colour_map indigo 75-0-130
tcl::dict::set TK_colour_map ivory 255-255-240
tcl::dict::set TK_colour_map ivory1 255-255-240
tcl::dict::set TK_colour_map ivory2 238-238-224
tcl::dict::set TK_colour_map ivory3 205-205-193
tcl::dict::set TK_colour_map ivory4 139-139-131
tcl::dict::set TK_colour_map khaki 240-230-140
tcl::dict::set TK_colour_map khaki1 255-246-143
tcl::dict::set TK_colour_map khaki2 238-230-133
tcl::dict::set TK_colour_map khaki3 205-198-115
tcl::dict::set TK_colour_map khaki4 139-134-78
tcl::dict::set TK_colour_map lavender 230-230-250
tcl::dict::set TK_colour_map "lavender blush" 255-240-245
tcl::dict::set TK_colour_map LavenderBlush 255-240-245
tcl::dict::set TK_colour_map LavenderBlush1 255-240-245
tcl::dict::set TK_colour_map LavenderBlush2 238-224-229
tcl::dict::set TK_colour_map LavenderBlush3 205-193-197
tcl::dict::set TK_colour_map LavenderBlush4 139-131-134
tcl::dict::set TK_colour_map "lawn green" 124-252-0
tcl::dict::set TK_colour_map LawnGreen 124-252-0
tcl::dict::set TK_colour_map "lemon chiffon" 255-250-205
tcl::dict::set TK_colour_map LemonChiffon 255-250-205
tcl::dict::set TK_colour_map LemonChiffon1 255-250-205
tcl::dict::set TK_colour_map LemonChiffon2 238-233-191
tcl::dict::set TK_colour_map LemonChiffon3 205-201-165
tcl::dict::set TK_colour_map LemonChiffon4 139-137-112
tcl::dict::set TK_colour_map "light blue" 173-216-230
tcl::dict::set TK_colour_map "light coral" 240-128-128
tcl::dict::set TK_colour_map "light cyan" 224-255-255
tcl::dict::set TK_colour_map "light goldenrod" 238-221-130
tcl::dict::set TK_colour_map "light goldenrod yellow" 250-250-210
tcl::dict::set TK_colour_map "light gray" 211-211-211
tcl::dict::set TK_colour_map "light green" 144-238-144
tcl::dict::set TK_colour_map "light grey" 211-211-211
tcl::dict::set TK_colour_map "light pink" 255-182-193
tcl::dict::set TK_colour_map "light salmon" 255-160-122
tcl::dict::set TK_colour_map "light sea green" 32-178-170
tcl::dict::set TK_colour_map "light sky blue" 135-206-250
tcl::dict::set TK_colour_map "light slate blue" 132-112-255
tcl::dict::set TK_colour_map "light slate gray" 119-136-153
tcl::dict::set TK_colour_map "light slate grey" 119-136-153
tcl::dict::set TK_colour_map "light steel blue" 176-196-222
tcl::dict::set TK_colour_map "light yellow" 255-255-224
tcl::dict::set TK_colour_map LightBlue 173-216-230
tcl::dict::set TK_colour_map LightBlue1 191-239-255
tcl::dict::set TK_colour_map LightBlue2 178-223-238
tcl::dict::set TK_colour_map LightBlue3 154-192-205
tcl::dict::set TK_colour_map LightBlue4 104-131-139
tcl::dict::set TK_colour_map LightCoral 240-128-128
tcl::dict::set TK_colour_map LightCyan 224-255-255
tcl::dict::set TK_colour_map LightCyan1 224-255-255
tcl::dict::set TK_colour_map LightCyan2 209-238-238
tcl::dict::set TK_colour_map LightCyan3 180-205-205
tcl::dict::set TK_colour_map LightCyan4 122-139-139
tcl::dict::set TK_colour_map LightGoldenrod 238-221-130
tcl::dict::set TK_colour_map LightGoldenrod1 255-236-139
tcl::dict::set TK_colour_map LightGoldenrod2 238-220-130
tcl::dict::set TK_colour_map LightGoldenrod3 205-190-112
tcl::dict::set TK_colour_map LightGoldenrod4 139-129-76
tcl::dict::set TK_colour_map LightGoldenrodYellow 250-250-210
tcl::dict::set TK_colour_map LightGray 211-211-211
tcl::dict::set TK_colour_map LightGreen 144-238-144
tcl::dict::set TK_colour_map LightGrey 211-211-211
tcl::dict::set TK_colour_map LightPink 255-182-193
tcl::dict::set TK_colour_map LightPink1 255-174-185
tcl::dict::set TK_colour_map LightPink2 238-162-173
tcl::dict::set TK_colour_map LightPink3 205-140-149
tcl::dict::set TK_colour_map LightPink4 139-95-101
tcl::dict::set TK_colour_map LightSalmon 255-160-122
tcl::dict::set TK_colour_map LightSalmon1 255-160-122
tcl::dict::set TK_colour_map LightSalmon2 238-149-114
tcl::dict::set TK_colour_map LightSalmon3 205-129-98
tcl::dict::set TK_colour_map LightSalmon4 139-87-66
tcl::dict::set TK_colour_map LightSeaGreen 32-178-170
tcl::dict::set TK_colour_map LightSkyBlue 135-206-250
tcl::dict::set TK_colour_map LightSkyBlue1 176-226-255
tcl::dict::set TK_colour_map LightSkyBlue2 164-211-238
tcl::dict::set TK_colour_map LightSkyBlue3 141-182-205
tcl::dict::set TK_colour_map LightSkyBlue4 96-123-139
tcl::dict::set TK_colour_map LightSlateBlue 132-112-255
tcl::dict::set TK_colour_map LightSlateGray 119-136-153
tcl::dict::set TK_colour_map LightSlateGrey 119-136-153
tcl::dict::set TK_colour_map LightSteelBlue 176-196-222
tcl::dict::set TK_colour_map LightSteelBlue1 202-225-255
tcl::dict::set TK_colour_map LightSteelBlue2 188-210-238
tcl::dict::set TK_colour_map LightSteelBlue3 162-181-205
tcl::dict::set TK_colour_map LightSteelBlue4 110-123-139
tcl::dict::set TK_colour_map LightYellow 255-255-224
tcl::dict::set TK_colour_map LightYellow1 255-255-224
tcl::dict::set TK_colour_map LightYellow2 238-238-209
tcl::dict::set TK_colour_map LightYellow3 205-205-180
tcl::dict::set TK_colour_map LightYellow4 139-139-122
tcl::dict::set TK_colour_map lime 0-255-0
tcl::dict::set TK_colour_map "lime green" 50-205-50
tcl::dict::set TK_colour_map LimeGreen 50-205-50
tcl::dict::set TK_colour_map linen 250-240-230
tcl::dict::set TK_colour_map magenta 255-0-255
tcl::dict::set TK_colour_map magenta1 255-0-255
tcl::dict::set TK_colour_map magenta2 238-0-238
tcl::dict::set TK_colour_map magenta3 205-0-205
tcl::dict::set TK_colour_map magenta4 139-0-139
tcl::dict::set TK_colour_map maroon 128-0-0
tcl::dict::set TK_colour_map maroon1 255-52-179
tcl::dict::set TK_colour_map maroon2 238-48-167
tcl::dict::set TK_colour_map maroon3 205-41-144
tcl::dict::set TK_colour_map maroon4 139-28-98
tcl::dict::set TK_colour_map "medium aquamarine" 102-205-170
tcl::dict::set TK_colour_map "medium blue" 0-0-205
tcl::dict::set TK_colour_map "medium orchid" 186-85-211
tcl::dict::set TK_colour_map "medium purple" 147-112-219
tcl::dict::set TK_colour_map "medium sea green" 60-179-113
tcl::dict::set TK_colour_map "medium slate blue" 123-104-238
tcl::dict::set TK_colour_map "medium spring green" 0-250-154
tcl::dict::set TK_colour_map "medium turquoise" 72-209-204
tcl::dict::set TK_colour_map "medium violet red" 199-21-133
tcl::dict::set TK_colour_map MediumAquamarine 102-205-170
tcl::dict::set TK_colour_map MediumBlue 0-0-205
tcl::dict::set TK_colour_map MediumOrchid 186-85-211
tcl::dict::set TK_colour_map MediumOrchid1 224-102-255
tcl::dict::set TK_colour_map MediumOrchid2 209-95-238
tcl::dict::set TK_colour_map MediumOrchid3 180-82-205
tcl::dict::set TK_colour_map MediumOrchid4 122-55-139
tcl::dict::set TK_colour_map MediumPurple 147-112-219
tcl::dict::set TK_colour_map MediumPurple1 171-130-255
tcl::dict::set TK_colour_map MediumPurple2 159-121-238
tcl::dict::set TK_colour_map MediumPurple3 137-104-205
tcl::dict::set TK_colour_map MediumPurple4 93-71-139
tcl::dict::set TK_colour_map MediumSeaGreen 60-179-113
tcl::dict::set TK_colour_map MediumSlateBlue 123-104-238
tcl::dict::set TK_colour_map MediumSpringGreen 0-250-154
tcl::dict::set TK_colour_map MediumTurquoise 72-209-204
tcl::dict::set TK_colour_map MediumVioletRed 199-21-133
tcl::dict::set TK_colour_map "midnight blue" 25-25-112
tcl::dict::set TK_colour_map MidnightBlue 25-25-112
tcl::dict::set TK_colour_map "mint cream" 245-255-250
tcl::dict::set TK_colour_map MintCream 245-255-250
tcl::dict::set TK_colour_map "misty rose" 255-228-225
tcl::dict::set TK_colour_map MistyRose 255-228-225
tcl::dict::set TK_colour_map MistyRose1 255-228-225
tcl::dict::set TK_colour_map MistyRose2 238-213-210
tcl::dict::set TK_colour_map MistyRose3 205-183-181
tcl::dict::set TK_colour_map MistyRose4 139-125-123
tcl::dict::set TK_colour_map moccasin 255-228-181
tcl::dict::set TK_colour_map "navajo white" 255-222-173
tcl::dict::set TK_colour_map NavajoWhite 255-222-173
tcl::dict::set TK_colour_map NavajoWhite1 255-222-173
tcl::dict::set TK_colour_map NavajoWhite2 238-207-161
tcl::dict::set TK_colour_map NavajoWhite3 205-179-139
tcl::dict::set TK_colour_map NavajoWhite4 139-121-94
tcl::dict::set TK_colour_map navy 0-0-128
tcl::dict::set TK_colour_map "navy blue" 0-0-128
tcl::dict::set TK_colour_map NavyBlue 0-0-128
tcl::dict::set TK_colour_map "old lace" 253-245-230
tcl::dict::set TK_colour_map OldLace 253-245-230
tcl::dict::set TK_colour_map olive 128-128-0
tcl::dict::set TK_colour_map "olive drab" 107-142-35
tcl::dict::set TK_colour_map OliveDrab 107-142-35
tcl::dict::set TK_colour_map OliveDrab1 192-255-62
tcl::dict::set TK_colour_map OliveDrab2 179-238-58
tcl::dict::set TK_colour_map OliveDrab3 154-205-50
tcl::dict::set TK_colour_map OliveDrab4 105-139-34
tcl::dict::set TK_colour_map orange 255-165-0
tcl::dict::set TK_colour_map "orange red" 255-69-0
tcl::dict::set TK_colour_map orange1 255-165-0
tcl::dict::set TK_colour_map orange2 238-154-0
tcl::dict::set TK_colour_map orange3 205-133-0
tcl::dict::set TK_colour_map orange4 139-90-0
tcl::dict::set TK_colour_map OrangeRed 255-69-0
tcl::dict::set TK_colour_map OrangeRed1 255-69-0
tcl::dict::set TK_colour_map OrangeRed2 238-64-0
tcl::dict::set TK_colour_map OrangeRed3 205-55-0
tcl::dict::set TK_colour_map OrangeRed4 139-37-0
tcl::dict::set TK_colour_map orchid 218-112-214
tcl::dict::set TK_colour_map orchid1 255-131-250
tcl::dict::set TK_colour_map orchid2 238-122-233
tcl::dict::set TK_colour_map orchid3 205-105-201
tcl::dict::set TK_colour_map orchid4 139-71-137
tcl::dict::set TK_colour_map "pale goldenrod" 238-232-170
tcl::dict::set TK_colour_map "pale green" 152-251-152
tcl::dict::set TK_colour_map "pale turquoise" 175-238-238
tcl::dict::set TK_colour_map "pale violet red" 219-112-147
tcl::dict::set TK_colour_map PaleGoldenrod 238-232-170
tcl::dict::set TK_colour_map PaleGreen 152-251-152
tcl::dict::set TK_colour_map PaleGreen1 154-255-154
tcl::dict::set TK_colour_map PaleGreen2 144-238-144
tcl::dict::set TK_colour_map PaleGreen3 124-205-124
tcl::dict::set TK_colour_map PaleGreen4 84-139-84
tcl::dict::set TK_colour_map PaleTurquoise 175-238-238
tcl::dict::set TK_colour_map PaleTurquoise1 187-255-255
tcl::dict::set TK_colour_map PaleTurquoise2 174-238-238
tcl::dict::set TK_colour_map PaleTurquoise3 150-205-205
tcl::dict::set TK_colour_map PaleTurquoise4 102-139-139
tcl::dict::set TK_colour_map PaleVioletRed 219-112-147
tcl::dict::set TK_colour_map PaleVioletRed1 255-130-171
tcl::dict::set TK_colour_map PaleVioletRed2 238-121-159
tcl::dict::set TK_colour_map PaleVioletRed3 205-104-127
tcl::dict::set TK_colour_map PaleVioletRed4 139-71-93
tcl::dict::set TK_colour_map "papaya whip" 255-239-213
tcl::dict::set TK_colour_map PapayaWhip 255-239-213
tcl::dict::set TK_colour_map "peach puff" 255-218-185
tcl::dict::set TK_colour_map PeachPuff 255-218-185
tcl::dict::set TK_colour_map PeachPuff1 255-218-185
tcl::dict::set TK_colour_map PeachPuff2 238-203-173
tcl::dict::set TK_colour_map PeachPuff3 205-175-149
tcl::dict::set TK_colour_map PeachPuff4 139-119-101
tcl::dict::set TK_colour_map peru 205-133-63
tcl::dict::set TK_colour_map pink 255-192-203
tcl::dict::set TK_colour_map pink1 255-181-197
tcl::dict::set TK_colour_map pink2 238-169-184
tcl::dict::set TK_colour_map pink3 205-145-158
tcl::dict::set TK_colour_map pink4 139-99-108
tcl::dict::set TK_colour_map plum 221-160-221
tcl::dict::set TK_colour_map plum1 255-187-255
tcl::dict::set TK_colour_map plum2 238-174-238
tcl::dict::set TK_colour_map plum3 205-150-205
tcl::dict::set TK_colour_map plum4 139-102-139
tcl::dict::set TK_colour_map "powder blue" 176-224-230
tcl::dict::set TK_colour_map PowderBlue 176-224-230
tcl::dict::set TK_colour_map purple 128-0-128
tcl::dict::set TK_colour_map purple1 155-48-255
tcl::dict::set TK_colour_map purple2 145-44-238
tcl::dict::set TK_colour_map purple3 125-38-205
tcl::dict::set TK_colour_map purple4 85-26-139
tcl::dict::set TK_colour_map red 255-0-0
tcl::dict::set TK_colour_map red1 255-0-0
tcl::dict::set TK_colour_map red2 238-0-0
tcl::dict::set TK_colour_map red3 205-0-0
tcl::dict::set TK_colour_map red4 139-0-0
tcl::dict::set TK_colour_map "rosy brown" 188-143-143
tcl::dict::set TK_colour_map RosyBrown 188-143-143
tcl::dict::set TK_colour_map RosyBrown1 255-193-193
tcl::dict::set TK_colour_map RosyBrown2 238-180-180
tcl::dict::set TK_colour_map RosyBrown3 205-155-155
tcl::dict::set TK_colour_map RosyBrown4 139-105-105
tcl::dict::set TK_colour_map "royal blue" 65-105-225
tcl::dict::set TK_colour_map RoyalBlue 65-105-225
tcl::dict::set TK_colour_map RoyalBlue1 72-118-255
tcl::dict::set TK_colour_map RoyalBlue2 67-110-238
tcl::dict::set TK_colour_map RoyalBlue3 58-95-205
tcl::dict::set TK_colour_map RoyalBlue4 39-64-139
tcl::dict::set TK_colour_map "saddle brown" 139-69-19
tcl::dict::set TK_colour_map SaddleBrown 139-69-19
tcl::dict::set TK_colour_map salmon 250-128-114
tcl::dict::set TK_colour_map salmon1 255-140-105
tcl::dict::set TK_colour_map salmon2 238-130-98
tcl::dict::set TK_colour_map salmon3 205-112-84
tcl::dict::set TK_colour_map salmon4 139-76-57
tcl::dict::set TK_colour_map "sandy brown" 244-164-96
tcl::dict::set TK_colour_map SandyBrown 244-164-96
tcl::dict::set TK_colour_map "sea green" 46-139-87
tcl::dict::set TK_colour_map SeaGreen 46-139-87
tcl::dict::set TK_colour_map SeaGreen1 84-255-159
tcl::dict::set TK_colour_map SeaGreen2 78-238-148
tcl::dict::set TK_colour_map SeaGreen3 67-205-128
tcl::dict::set TK_colour_map SeaGreen4 46-139-87
tcl::dict::set TK_colour_map seashell 255-245-238
tcl::dict::set TK_colour_map seashell1 255-245-238
tcl::dict::set TK_colour_map seashell2 238-229-222
tcl::dict::set TK_colour_map seashell3 205-197-191
tcl::dict::set TK_colour_map seashell4 139-134-130
tcl::dict::set TK_colour_map sienna 160-82-45
tcl::dict::set TK_colour_map sienna1 255-130-71
tcl::dict::set TK_colour_map sienna2 238-121-66
tcl::dict::set TK_colour_map sienna3 205-104-57
tcl::dict::set TK_colour_map sienna4 139-71-38
tcl::dict::set TK_colour_map silver 192-192-192
tcl::dict::set TK_colour_map "sky blue" 135-206-235
tcl::dict::set TK_colour_map SkyBlue 135-206-235
tcl::dict::set TK_colour_map SkyBlue1 135-206-255
tcl::dict::set TK_colour_map SkyBlue2 126-192-238
tcl::dict::set TK_colour_map SkyBlue3 108-166-205
tcl::dict::set TK_colour_map SkyBlue4 74-112-139
tcl::dict::set TK_colour_map "slate blue" 106-90-205
tcl::dict::set TK_colour_map "slate gray" 112-128-144
tcl::dict::set TK_colour_map "slate grey" 112-128-144
tcl::dict::set TK_colour_map SlateBlue 106-90-205
tcl::dict::set TK_colour_map SlateBlue1 131-111-255
tcl::dict::set TK_colour_map SlateBlue2 122-103-238
tcl::dict::set TK_colour_map SlateBlue3 105-89-205
tcl::dict::set TK_colour_map SlateBlue4 71-60-139
tcl::dict::set TK_colour_map SlateGray 112-128-144
tcl::dict::set TK_colour_map SlateGray1 198-226-255
tcl::dict::set TK_colour_map SlateGray2 185-211-238
tcl::dict::set TK_colour_map SlateGray3 159-182-205
tcl::dict::set TK_colour_map SlateGray4 108-123-139
tcl::dict::set TK_colour_map SlateGrey 112-128-144
tcl::dict::set TK_colour_map snow 255-250-250
tcl::dict::set TK_colour_map snow1 255-250-250
tcl::dict::set TK_colour_map snow2 238-233-233
tcl::dict::set TK_colour_map snow3 205-201-201
tcl::dict::set TK_colour_map snow4 139-137-137
tcl::dict::set TK_colour_map "spring green" 0-255-127
tcl::dict::set TK_colour_map SpringGreen 0-255-127
tcl::dict::set TK_colour_map SpringGreen1 0-255-127
tcl::dict::set TK_colour_map SpringGreen2 0-238-118
tcl::dict::set TK_colour_map SpringGreen3 0-205-102
tcl::dict::set TK_colour_map SpringGreen4 0-139-69
tcl::dict::set TK_colour_map "steel blue" 70-130-180
tcl::dict::set TK_colour_map SteelBlue 70-130-180
tcl::dict::set TK_colour_map SteelBlue1 99-184-255
tcl::dict::set TK_colour_map SteelBlue2 92-172-238
tcl::dict::set TK_colour_map SteelBlue3 79-148-205
tcl::dict::set TK_colour_map SteelBlue4 54-100-139
tcl::dict::set TK_colour_map tan 210-180-140
tcl::dict::set TK_colour_map tan1 255-165-79
tcl::dict::set TK_colour_map tan2 238-154-73
tcl::dict::set TK_colour_map tan3 205-133-63
tcl::dict::set TK_colour_map tan4 139-90-43
tcl::dict::set TK_colour_map teal 0-128-128
tcl::dict::set TK_colour_map thistle 216-191-216
tcl::dict::set TK_colour_map thistle1 255-225-255
tcl::dict::set TK_colour_map thistle2 238-210-238
tcl::dict::set TK_colour_map thistle3 205-181-205
tcl::dict::set TK_colour_map thistle4 139-123-139
tcl::dict::set TK_colour_map tomato 255-99-71
tcl::dict::set TK_colour_map tomato1 255-99-71
tcl::dict::set TK_colour_map tomato2 238-92-66
tcl::dict::set TK_colour_map tomato3 205-79-57
tcl::dict::set TK_colour_map tomato4 139-54-38
tcl::dict::set TK_colour_map turquoise 64-224-208
tcl::dict::set TK_colour_map turquoise1 0-245-255
tcl::dict::set TK_colour_map turquoise2 0-229-238
tcl::dict::set TK_colour_map turquoise3 0-197-205
tcl::dict::set TK_colour_map turquoise4 0-134-139
tcl::dict::set TK_colour_map violet 238-130-238
tcl::dict::set TK_colour_map "violet red" 208-32-144
tcl::dict::set TK_colour_map VioletRed 208-32-144
tcl::dict::set TK_colour_map VioletRed1 255-62-150
tcl::dict::set TK_colour_map VioletRed2 238-58-140
tcl::dict::set TK_colour_map VioletRed3 205-50-120
tcl::dict::set TK_colour_map VioletRed4 139-34-82
tcl::dict::set TK_colour_map wheat 245-222-179
tcl::dict::set TK_colour_map wheat1 255-231-186
tcl::dict::set TK_colour_map wheat2 238-216-174
tcl::dict::set TK_colour_map wheat3 205-186-150
tcl::dict::set TK_colour_map wheat4 139-126-102
tcl::dict::set TK_colour_map white 255-255-255
tcl::dict::set TK_colour_map "white smoke" 245-245-245
tcl::dict::set TK_colour_map WhiteSmoke 245-245-245
tcl::dict::set TK_colour_map yellow 255-255-0
tcl::dict::set TK_colour_map "yellow green" 154-205-50
tcl::dict::set TK_colour_map yellow1 255-255-0
tcl::dict::set TK_colour_map yellow2 238-238-0
tcl::dict::set TK_colour_map yellow3 205-205-0
tcl::dict::set TK_colour_map yellow4 139-139-0
tcl::dict::set TK_colour_map YellowGreen 154-205-50
variable TK_colour_map_lookup ;#same dict but with lower-case versions added
set TK_colour_map_lookup $TK_colour_map
dict for {key val} $TK_colour_map {
dict set TK_colour_map_lookup [tcl::string::tolower $key] $val ;#no need to test if already present - just set.
}
variable TK_colour_map_reverse [dict create]
dict for {key val} $TK_colour_map {
dict lappend TK_colour_map_reverse $val $key
}
#using same order as inital colour map
variable TK_colour_map_merge [dict create]
set seen_names [dict create]
dict for {key val} $TK_colour_map {
if {[dict exists $seen_names $key]} {
continue
}
set allnames [dict get $TK_colour_map_reverse $val]
set names [list]
foreach n $allnames {
if {$n ne $key} {
lappend names $n
}
}
dict set TK_colour_map_merge $key [dict create colour $val names $names]
foreach n $names {
dict set seen_names $n 1
}
}
unset seen_names
#*** !doctools
#[list_end] [comment {--- end definitions namespace ::punk::ansi::colourmap ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval ::punk::ansi::colourmap::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace ::punk::ansi::colourmap::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::ansi::colourmap::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# -----------------------------------------------------------------------------
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked
# -----------------------------------------------------------------------------
# variable PUNKARGS
# variable PUNKARGS_aliases
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::punk::ansi::colourmap
}
# -----------------------------------------------------------------------------
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::ansi::colourmap [tcl::namespace::eval ::punk::ansi::colourmap {
variable pkg ::punk::ansi::colourmap
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

683
src/vfs/_vfscommon.vfs/modules/punk/args-0.1.9.tm
View File

File diff suppressed because it is too large Load Diff

9550
src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm
View File

File diff suppressed because it is too large Load Diff

2330
src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm
View File

File diff suppressed because it is too large Load Diff

622
src/vfs/_vfscommon.vfs/modules/punk/args/tkcore-0.1.0.tm
Unescape View File

@ -0,0 +1,622 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# 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) 2025
#
# @@ Meta Begin
# Application punk::args::tkcore 0.1.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::args::tkcore 0 0.1.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require punk::args::tkcore]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::args::tkcore
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::args::tkcore
#[list_begin itemized]
package require Tcl 8.6-
package require punk::args
package require punk::ansi
package require textblock
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package {punk::args}]
#[item] [package {textblock}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
tcl::namespace::eval punk::args::tkcore {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection {Namespace punk::args::tkcore}]
#[para] Core API functions for punk::args::tkcore
#[list_begin definitions]
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
set A_WARN \x1b\[7m
set A_RST \x1b\[0m
variable manbase
variable manbase_ext
set patch [info patchlevel]
lassign [split $patch .] major
if {$major < 9} {
set manbase "https://tcl.tk/man/tcl/TkCmd"
set manbase_ext .htm
} else {
set manbase "https://tcl.tk/man/tcl9.0/TkCmd"
set manbase_ext .html
}
proc manpage {cmd} {
variable manbase
variable manbase_ext
return ${manbase}/${cmd}${manbase_ext}
}
variable PUNKARGS
namespace eval argdoc {
tcl::namespace::import ::punk::ansi::a+
tcl::namespace::import ::punk::args::tkcore::manpage
# -- --- --- --- ---
#non colour SGR codes
# we can use these directly via ${$I} etc without marking a definition with @dynamic
#This is because they don't need to change when colour switched on and off.
set I [a+ italic]
set NI [a+ noitalic]
set B [a+ bold]
set N [a+ normal]
# -- --- --- --- ---
proc example {str} {
set str [string trimleft $str \n]
set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Web-gray bold white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]]
set result [textblock::bookend_lines $block [a] "[a defaultbg] [a]"]
#puts $result
return $result
}
}
namespace eval argdoc {
lappend PUNKARGS [list {
@id -id "(default)::punk::args::tkcore::common"
} "@doc -name Manpage: -url [manpage index]" ]
#list all tk_standardoptions
#use punk::args::resolved_spec
#{${[punk::args::resolved_def -types opts (default)::punk::args::tkcore::tk_standardoptions -disabledforeground -font ...]}}
::punk::args::define {
@id -id "(default)::punk::args::tkcore::tk_standardoptions"
-activebackground -type colour -help\
"Specifies background color to use when drawing active elements. An element (a widget or portion of a widget)
is active if the mouse cursor is positioned over the element and pressing a mouse button will cause some
action to occur. If strict Motif compliance has been requested by setting the tk_strictMotif variable, this
option will normally be ignored; the normal background color will be used instead. For some elements on
Windows and Macintosh systems, the active color will only be used while mouse button 1 is pressed over the
element."
-activeborderwidth -type tk_screen_units -help\
"Specifies a non-negative value indicating the width of the 3-D border drawn around active elements. See above
for definition of active elements. The value may have any of the forms acceptable to Tk_GetPixels. This option
is typically only available in widgets displaying more than one element at a time (e.g. menus but not buttons)."
-activeforeground -type colour -help\
"Specifies foreground color to use when drawing active elements. See above for definition of active elements."
-activerelief -type string -choicecolumns 6 -choices {raised sunken flat ridge solid groove} -help\
"Specifies the 3-D effect desired for the active item of the widget. See the -relief option for details."
-anchor -type string -choicecolumns 9 -choices {n ne e se s sw w nw center} -help\
"Specifies how the information in a widget (e.g. text or a bitmap) is to be displayed in the widget.
For example, ${$B}nw${$N} means display the information such that its top-left corner is at the top-left corner of the widget."
-background|-bg -type colour -help\
"Specifies the normal background color to use when displaying the widget."
-bitmap -type bmp -help\
"Specifies a bitmap to display in the widget, in any of the forms acceptable to Tk_GetBitmap. The exact
way in which the bitmap is displayed may be affected by other options such as -anchor or -justify.
Typically, if this option is specified then it overrides other options that specify a textual value to
display in the widget but this is controlled by the ${$B}-compound${$N} option; the -bitmap option may be reset to
an empty string to re-enable a text display. In widgets that support both -bitmap and -image options,
-image will usually override -bitmap."
-borderwidth|-bd -type tk_screen_units -help\
"Specifies a non-negative value indicating the width of the 3-D border to draw around the outside of the
widget (if such a border is being drawn; the -relief option typically determines this). The value may
also be used when drawing 3-D effects in the interior of the widget. The value may have any of the
forms acceptable to Tk_GetPixels."
#todo - something better for large -choices lists
#list of cursors is large, not obtainable dynamically, and has some that are platform specific.
-cursor -type string -help\
""
-compound -type string -choicecolumns 6 -choices {none bottom top left right center} -help\
"Specifies if the widget should display text and bitmaps/images at the same time, and if so, where the
bitmap/image should be placed relative to the text. Must be one of the values none, bottom, top, left,
right, or center. For example, the (default) value none specifies that the bitmap or image should
(if defined) be displayed instead of the text, the value ${$B}left${$N} specifies that the bitmap or image should
be displayed to the left of the text, and the value ${$B}center${$N} specifies that the bitmap or image should be
displayed on top of the text."
-disabledforeground -type colour|literal() -help\
"Specifies foreground color to use when drawing a disabled element. If the option is specified
as an empty string (which is typically the case on monochrome displays), disabled elements
are drawn with the normal foreground color but they are dimmed by drawing them with a
stippled fill pattern."
-exportselection -type boolean -help\
"Specifies whether or not a selection in the widget should also be the X selection. The value may have any of the
forms accepted by Tcl_GetBoolean, such as true, false, 0, 1, yes, or no. If the selection is exported, then
selecting in the widget deselects the current X selection, selecting outside the widget deselects any widget
selection, and the widget will respond to selection retrieval requests when it has a selection. The default is
usually for widgets to export selections."
-font -type tk_font -help\
"Specifies the font to use when drawing text inside the widget. The value may have any of the
forms described in the font manual page under FONT DESCRIPTION."
-foreground|-fg -type colour -help\
"Specifies the normal foreground color to use when displaying the widget."
-highlightbackground -type colour -help\
"Specifies the color to display in the traversal highlight region when the widget does not have the input focus."
-highlightcolor -type colour -help\
"Specifies the color to use for the traversal highlight rectangle that is drawn around the widget when it has the
input focus."
-highlightthicknes -type tk_screen_units -help\
"Specifies a non-negative value indicating the width of the highlight rectangle to draw around the outside of the
widget when it has the input focus. The value may have any of the forms acceptable to Tk_GetPixels. If the
value is zero, no focus highlight is drawn around the widget."
-image -type string -help\
"Specifies an image to display in the widget, which must have been created with the image create command.
Typically, if the -image option is specified then it overrides other options that specify a bitmap or textual
value to display in the widget, though this is controlled by the -compound option; the -image option may be
reset to an empty string to re-enable a bitmap or text display."
-insertbackground -type colour -help\
"Specifies the color to use as background in the area covered by the insertion cursor. This color will normally
override either the normal background for the widget (or the selection background if the insertion cursor
happens to fall in the selection)."
-insertborderwidth -type tk_screen_units -help\
"Specifies a non-negative value indicating the width of the 3-D border to draw around the insertion cursor.
The value may have any of the forms acceptable to Tk_GetPixels."
-insertofftime -type integer -typesynopsis {${$I}ms${$NI}} -range {0 ""} -help\
"Specifies a non-negative integer value indicating the number of milliseconds the insertion cursor should remain
“off” in each blink cycle. If this option is zero then the cursor does not blink: it is on all the time."
-insertontime -type integer -typesynopsis {${$I}ms${$NI}} -range {0 ""} -help\
"Specifies a non-negative integer value indicating the number of milliseconds the insertion cursor should remain
“on” in each blink cycle."
-insertwidth -type tk_screen_units -help\
"Specifies a non-negative value indicating the total width of the insertion cursor. The value may have any of the
forms acceptable to Tk_GetPixels. If a border has been specified for the insertion cursor (using the
-insertborderwidth option), the border will be drawn inside the width specified by the -insertwidth option."
-jump -type boolean -help\
"For widgets with a slider that can be dragged to adjust a value, such as scrollbars, this option determines when
notifications are made about changes in the value. The option's value must be a boolean of the form accepted by
Tcl_GetBoolean. If the value is false, updates are made continuously as the slider is dragged. If the value is
true, updates are delayed until the mouse button is released to end the drag; at that point a single
notification is made (the value “jumps” rather than changing smoothly)."
-justify -type string -choicecolumns 3 -choices {left center right} -help\
"When there are multiple lines of text displayed in a widget, this option determines how the lines line up with
each other. Must be one of left, center, or right. Left means that the lines' left edges all line up, center
means that the lines' centers are aligned, and right means that the lines' right edges line up."
-orient -type string -choiceprefix 1 -choicecolumns 2 -choices {horizontal vertical} -help\
"For widgets that can lay themselves out with either a horizontal or vertical orientation, such as scrollbars,
this option specifies which orientation should be used. Must be either horizontal or vertical or an
abbreviation of one of these."
-padx -type tk_screen_units -help\
"Specifies a non-negative value indicating how much extra space to request for the widget in the X-direction.
The value may have any of the forms acceptable to Tk_GetPixels. When computing how large a window it needs,
the widget will add this amount to the width it would normally need (as determined by the width of the things
displayed in the widget); if the geometry manager can satisfy this request, the widget will end up with extra
internal space to the left and/or right of what it displays inside. Most widgets only use this option for
padding text: if they are displaying a bitmap or image, then they usually ignore padding options."
-pady -type tk_screen_units -help\
"Specifies a non-negative value indicating how much extra space to request for the widget in the Y-direction.
The value may have any of the forms acceptable to Tk_GetPixels. When computing how large a window it needs,
the widget will add this amount to the height it would normally need (as determined by the height of the things
displayed in the widget); if the geometry manager can satisfy this request, the widget will end up with extra
internal space above and/or below what it displays inside. Most widgets only use this option for padding text:
if they are displaying a bitmap or image, then they usually ignore padding options."
-placeholder -type string -help\
"Specifies a help text string to display if no text is otherwise displayed, that is when the widget is empty.
The placeholder text is displayed using the values of the -font and -justify options."
-placeholderforeground -type colour -help\
"Specifies the foreground color to use when the placeholder text is displayed.
The default color is platform-specific."
-relief -type string -choicecolumns 6 -choices {raised sunken flat ridge solid groove} -help\
"Specifies the 3-D effect desired for the widget. Acceptable values are raised, sunken, flat, ridge, solid, and
groove. The value indicates how the interior of the widget should appear relative to its exterior; for example,
raised means the interior of the widget should appear to protrude from the screen, relative to the exterior of
the widget."
-repeatdelay -type integer -typesynopsis {${$I}ms${$NI}} -help\
"Specifies the number of milliseconds a button or key must be held down before it begins to auto-repeat. Used,
for example, on the up- and down-arrows in scrollbars."
-repeatinterval -type integer -typesynopsis {${$I}ms${$NI}} -help\
"Used in conjunction with -repeatdelay: once auto-repeat begins, this option determines the number of
milliseconds between auto-repeats."
-selectbackground -type colour -help\
"Specifies the background color to use when displaying selected items."
-selectborderwidth -type tk_screen_units -help\
"Specifies a non-negative value indicating the width of the 3-D border to draw around selected items.
The value may have any of the forms acceptable to Tk_GetPixels."
-selectforeground -type colour -help\
"Specifies the foreground color to use when displaying selected items."
-setgrid -type boolean -help\
"Specifies a boolean value that determines whether this widget controls the resizing grid for its top-level window.
This option is typically used in text widgets, where the information in the widget has a natural size (the size
of a character) and it makes sense for the window's dimensions to be integral numbers of these units. These
natural window sizes form a grid. If the -setgrid option is set to true then the widget will communicate with the
window manager so that when the user interactively resizes the top-level window that contains the widget, the
dimensions of the window will be displayed to the user in grid units and the window size will be constrained to
integral numbers of grid units. See the section GRIDDED GEOMETRY MANAGEMENT in the wm manual entry for more
details."
-takefocus -type literal(0)|literal(1)|literal() -help\
"Determines whether the window accepts the focus during keyboard traversal (e.g., Tab and Shift-Tab). Before
setting the focus to a window, the traversal scripts consult the value of the -takefocus option. A value of 0
means that the window should be skipped entirely during keyboard traversal. 1 means that the window should
receive the input focus as long as it is viewable (it and all of its ancestors are mapped). An empty value for
the option means that the traversal scripts make the decision about whether or not to focus on the window: the
current algorithm is to skip the window if it is disabled, if it has no key bindings, or if it is not viewable.
If the value has any other form, then the traversal scripts take the value, append the name of the window to it
(with a separator space), and evaluate the resulting string as a Tcl script. The script must return 0, 1, or an
empty string: a 0 or 1 value specifies whether the window will receive the input focus, and an empty string
results in the default decision described above. Note that this interpretation of the option is defined entirely
by the Tcl scripts that implement traversal: the widget implementations ignore the option entirely, so you can
change its meaning if you redefine the keyboard traversal scripts."
-text -type string -help\
"Specifies a string to be displayed inside the widget. The way in which the string is displayed depends on the
particular widget and may be determined by other options, such as -anchor or -justify."
-textvariable -type string -help\
"Specifies the name of a global variable. The value of the variable is a text string to be displayed inside the
widget; if the variable value changes then the widget will automatically update itself to reflect the new value.
The way in which the string is displayed in the widget depends on the particular widget and may be determined by
other options, such as -anchor or -justify."
-troughcolor -type colour -help\
"Specifies the color to use for the rectangular trough areas in widgets such as scrollbars and scales. This option
is ignored for scrollbars on Windows (native widget does not recognize this option)."
-underline -type indexexpression -help\
"Specifies the integer index of a character to underline in the widget. This option is used by the default
bindings to implement keyboard traversal for menu buttons and menu entries. 0 corresponds to the first character
of the text displayed in the widget, 1 to the next character, and so on. end corresponds to the last character,
end-1 to the before last character, and so on."
-wraplength -type tk_screen_units -help\
"For widgets that can perform word-wrapping, this option specifies the maximum line length. Lines that would
exceed this length are wrapped onto the next line, so that no line is longer than the specified length. The
value may be specified in any of the standard forms for screen distances. If this value is negative or zero
then no wrapping is done: lines will break only at newline characters in the text."
-xscrollcommand -type list -typesynopsis {${$I}cmdprefix${$NI}} -help\
"Specifies the prefix for a command used to communicate with horizontal scrollbars. When the view in the widget's
window changes (or whenever anything else occurs that could change the display in a scrollbar, such as a change
in the total size of the widget's contents), the widget will generate a Tcl command by concatenating the scroll
command and two numbers. Each of the numbers is a fraction between 0 and 1, which indicates a position in the
document. 0 indicates the beginning of the document, 1 indicates the end, .333 indicates a position one third
the way through the document, and so on. The first fraction indicates the first information in the document
that is visible in the window, and the second fraction indicates the information just after the last portion
that is visible. The command is then passed to the Tcl interpreter for execution. Typically the -xscrollcommand
option consists of the path name of a scrollbar widget followed by “set”, e.g. “.x.scrollbar set”: this will
cause the scrollbar to be updated whenever the view in the window changes. If this option is not specified,
then no command will be executed."
-yscrollcommand -type list -typesynopsis {${$I}cmdprefix${$NI}} -help\
"Specifies the prefix for a command used to communicate with vertical scrollbars. This option is treated in the
same way as the -xscrollcommand option, except that it is used for vertical scrollbars and is provided by
widgets that support vertical scrolling. See the description of -xscrollcommand for details on how this option
is used."
} "@doc -name Manpage: -url [manpage options]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list {
@id -id ::bell
@cmd -name "Tk Builtin: bell"\
-summary\
"Ring a display's bell."\
-help\
"This command rings the bell on the display for ${$I}window${$NI} and returns an empty string.
If the ${$B}-displayof${$N} option is omitted, the display of the application's main window
is used by default. The command uses the current bell-related settings for the
display, which may be modified with programs such as ${$B}xset${$N}.
If ${$B}-nice${$N} is not specified, this command also resets the screen saver for the screen.
Some screen savers will ignore this, but others will reset so that the screen
becomes visible again."
@opts
-displayof -type stringstartswith(.) -typesynopsis window
-nice -type none
@values -min 0 -max 0
} "@doc -name Manpage: -url [manpage bell]" ]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS_aliases {::button ::tk::button}
punk::args::define {
@id -id ::tk::button
@cmd -name "Tk Builtin: tk::button"\
-summary\
"Create and manipulate 'button' action widgets."\
-help\
"The ${$B}button${$N} command creates a new window (given by the ${$I}pathName${$NI} argument) and makes it into a button
widget. Additional options, described above, may be specified on the command line or in the option
database to configure aspects of the button such as its colors, font, text, and initial relief. The
${$B}button${$N} command returns its ${$I}pathName${$NI} argument. At the time this command is invoked, there must not
exist a window named ${$I}pathName${$NI}, but ${$I}pathName${$NI}'s parent must exist.
A button is a widget that displays a textual string, bitmap or image. If text is displayed, it must
all be in a single font, but it can occupy multiple lines on the screen (if it contains newlines or
if wrapping occurs because of the ${$B}-wraplength${$N} option) and one of the characters may optionally be
underlined using the ${$B}-underline${$N} option. It can display itself in either of three different ways,
according to the ${$B}-state${$N} option; it can be made to appear raised, sunken, or flat; and it can be made
to flash. When a user invokes the button (by pressing mouse button 1 with the cursor over the button),
then the Tcl command specified in the ${$B}-command${$N} option is invoked."
@leaders
pathName -type tk_path
@opts -type string -parsekey "" -group "STANDARD OPTIONS" -grouphelp\
""
}\
{${[punk::args::resolved_def -types opts (default)::punk::args::tkcore::tk_standardoptions\
-activebackground\
-activeforeground\
-anchor\
-background|-bg\
-bitmap\
-borderwidth|-bd\
-compound\
-cursor\
-disabledforeground\
-font\
-foreground|-fg\
-highligthbackground\
-highlightcolor\
-highlightthickness\
-image\
-justify\
-padx\
-pady\
-relief\
-takefocus\
-text\
-textvariable\
-underline\
-wraplength\
]}}\
{
@opts -type string -parsekey "" -group "WIDGET-SPECIFIC OPTIONS" -grouphelp\
""
-command -type script -help\
"Specifies a Tcl command to associate with the button. This command is typically invoked when mouse button 1
is released over the button window."
-default -type string -choices {normal active disabled} -help\
"Specifies one of three states for the default ring: normal, active, or disabled. In active state, the button
is drawn with the platform specific appearance for a default button. In normal state, the button is drawn
with the platform specific appearance for a non-default button, leaving enough space to draw the default
button appearance. The normal and active states will result in buttons of the same size. In disabled state,
the button is drawn with the non-default button appearance without leaving space for the default appearance.
The disabled state may result in a smaller button than the active state."
-height -type tk_screen_units -help\
"Specifies a desired height for the button. If an image or bitmap is being displayed in the button then the
value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text.
If this option is not specified, the button's desired height is computed from the size of the image or bitmap
or text being displayed in it."
-overrelief -type string -default "" -choicecolumns 7 -choices {raised sunken flat ridge solid groove ""} -help\
"Specifies an alternative relief for the button, to be used when the mouse cursor is over the widget. This
option can be used to make toolbar buttons, by configuring -relief flat -overrelief raised. If the value of
this option is the empty string, then no alternative relief is used when the mouse cursor is over the button.
The empty string is the default value."
-state -type string -choices {normal active disabled} -help\
"Specifies one of three states for the button: normal, active, or disabled. In normal state the button is
displayed using the ${$B}-foreground${$N} and ${$B}-background${$N} options. The active state is typically used when the pointer
is over the button. In active state the button is displayed using the ${$B}-activeforeground${$N} and ${$B}-activebackground${$N}
options. Disabled state means that the button should be insensitive: the default bindings will refuse to
activate the widget and will ignore mouse button presses. In this state the ${$B}-disabledforeground${$N} and
${$B}-background${$N} options determine how the button is displayed."
-width -type tk_screen_units -help\
"Specifies a desired width for the button. If an image or bitmap is being displayed in the button then the
value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels). For a text button (no image or
with -compound none) then the width specifies how much space in characters to allocate for the text label.
If the width is negative then this specifies a minimum width. If this option is not specified, the button's
desired width is computed from the size of the image or bitmap or text being displayed in it."
} "@doc -name Manpage: -url [manpage bell]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::args::tkcore ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::args::tkcore::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::args::tkcore::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::args::tkcore::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::args::tkcore::system {
#*** !doctools
#[subsection {Namespace punk::args::tkcore::system}]
#[para] Internal functions that are not part of the API
#}
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::args::tkcore {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
variable PUNKARGS
variable PUNKARGS_aliases
lappend PUNKARGS [list {
@id -id "(package)punk::args::tkcore"
@package -name "punk::args::tkcore" -help\
"Package
Description"
}]
namespace eval argdoc {
#namespace for custom argument documentation
proc package_name {} {
return punk::args::tkcore
}
proc about_topics {} {
#info commands results are returned in an arbitrary order (like array keys)
set topic_funs [info commands [namespace current]::get_topic_*]
set about_topics [list]
foreach f $topic_funs {
set tail [namespace tail $f]
lappend about_topics [string range $tail [string length get_topic_] end]
}
#Adjust this function or 'default_topics' if a different order is required
return [lsort $about_topics]
}
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
# get_topic_ functions add more to auto-include in about topics
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr [string trim {
package punk::args::tkcore
punk::args documentation for Tk
} \n]
}
proc get_topic_License {} {
return "MIT"
}
proc get_topic_Version {} {
return "$::punk::args::tkcore::version"
}
proc get_topic_Contributors {} {
set authors {{Julian Noble <julian@precisium.com.au}}
set contributors ""
foreach a $authors {
append contributors $a \n
}
if {[string index $contributors end] eq "\n"} {
set contributors [string range $contributors 0 end-1]
}
return $contributors
}
#proc get_topic_custom-topic {} {
# punk::args::lib::tstr -return string {
# ""
# }
#}
# -------------------------------------------------------------
}
# we re-use the argument definition from punk::args::standard_about and override some items
set overrides [dict create]
dict set overrides @id -id "::punk::args::tkcore::about"
dict set overrides @cmd -name "punk::args::tkcore::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About punk::args::tkcore
}] \n]
dict set overrides topic -choices [list {*}[punk::args::tkcore::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
dict set overrides topic -default [punk::args::tkcore::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *]
lappend PUNKARGS [list $newdef]
proc about {args} {
package require punk::args
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on
set argd [punk::args::parse $args withid ::punk::args::tkcore::about]
lassign [dict values $argd] _leaders opts values _received
punk::args::package::standard_about -package_about_namespace ::punk::args::tkcore::argdoc {*}$opts {*}[dict get $values topic]
}
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===
# -----------------------------------------------------------------------------
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked
# -----------------------------------------------------------------------------
# variable PUNKARGS
# variable PUNKARGS_aliases
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::punk::args::tkcore ::punk::args::tkcore::argdoc
}
# -----------------------------------------------------------------------------
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::args::tkcore [tcl::namespace::eval punk::args::tkcore {
variable pkg punk::args::tkcore
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

21
src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm
Unescape View File

@ -612,10 +612,12 @@ namespace eval punk::console {
-terminal -default {stdin stdout} -type list -help\
"terminal (currently list of in/out channels) (todo - object?)"
-expected_ms -default 100 -type integer -help\
-expected_ms -default 300 -type integer -help\
"Expected number of ms for response from terminal.
100ms is usually plenty for a local terminal and a
basic query such as cursor position."
basic query such as cursor position.
However on a busy machine a higher timeout may be
prudent."
@values -min 2 -max 2
query -type string -help\
"ANSI sequence such as \x1b\[?6n which
@ -687,12 +689,14 @@ namespace eval punk::console {
set queuedata($callid) $args
set runningid [lindex $queue 0]
while {$runningid ne $callid} {
#puts stderr "."
vwait ::punk::console::ansi_response_wait
set runningid [lindex $queue 0]
if {$runningid ne $callid} {
set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid)
update ;#REVIEW - probably a bad idea
after 10
set runningid [lindex $queue 0] ;#jn test
}
}
}
@ -779,7 +783,7 @@ namespace eval punk::console {
puts "blank extension $waitvar($callid)"
puts "->[set $waitvar($callid)]<-"
}
puts stderr "get_ansi_response_payload Extending timeout by $extension"
puts stderr "get_ansi_response_payload Extending timeout by $extension for callid:$callid"
after cancel $timeoutid($callid)
set total_elapsed [expr {[clock millis] - $tslaunch($callid)}]
set last_elapsed [expr {[clock millis] - $lastvwait}]
@ -916,7 +920,8 @@ namespace eval punk::console {
unset -nocomplain tslaunch($callid)
dict unset queuedata $callid
lpop queue 0
#lpop queue 0
ledit queue 0 0
if {[llength $queue] > 0} {
set next_callid [lindex $queue 0]
set waitvar($callid) go_ahead
@ -977,7 +982,7 @@ namespace eval punk::console {
set tsnow [clock millis]
set total_elapsed [expr {[set tslaunch($callid)] - $tsnow}]
set last_elapsed [expr {[set tsclock($callid)] - $tsnow}]
if {[string length $chunks($callid)] % 10 == 0 || $last_elapsed > 16} {
if {[string length $sofar] % 10 == 0 || $last_elapsed > 16} {
if {$total_elapsed > 3000} {
#REVIEW
#too long since initial read handler launched..
@ -1239,7 +1244,7 @@ namespace eval punk::console {
lappend PUNKARGS [list {
@id -id ::punk::console::show_input_response
@cmd -name punk::console::show_input_response -help\
""
"Debug command for console queries using ANSI"
@opts
-terminal -default {stdin stdout} -type list -help\
"terminal (currently list of in/out channels) (todo - object?)"
@ -1247,9 +1252,9 @@ namespace eval punk::console {
"Number of ms to wait for response"
@values -min 1 -max 1
request -type string -help\
"ANSI sequence such as \x1b\[?6n which
{ANSI sequence such as \x1b\[?6n which
should elicit a response by the terminal
on stdin"
on stdin}
}]
proc show_input_response {args} {
set argd [punk::args::parse $args withid ::punk::console::show_input_response]

1
src/vfs/_vfscommon.vfs/modules/punk/du-0.1.0.tm
Unescape View File

@ -70,6 +70,7 @@ namespace eval punk::du {
proc du { args } {
variable has_twapi
#todo - use punk::args
if 0 {
switch -exact [llength $args] {

135
src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.2.tm
Unescape View File

@ -301,6 +301,7 @@ tcl::namespace::eval punk::lib::compat {
if {"::lpop" ne [info commands ::lpop]} {
#puts stderr "Warning - no built-in lpop"
interp alias {} lpop {} ::punk::lib::compat::lpop
punk::args::set_alias ::punk::lib::compat::lpop ::lpop ;#point to the definition of ::lpop defined in punk::args::tclcore
}
proc lpop {lvar args} {
#*** !doctools
@ -339,6 +340,51 @@ tcl::namespace::eval punk::lib::compat {
set l $newlist
return $v
}
if {"::ledit" ni [info commands ::ledit]} {
interp alias {} ledit {} ::punk::lib::compat::ledit
punk::args::set_alias ::punk::lib::compat::ledit ::ledit
}
proc ledit {lvar first last args} {
upvar $lvar l
#use lindex_resolve to support for example: ledit lst end+1 end+1 h i
set fidx [punk::lib::lindex_resolve $l $first]
switch -exact -- $fidx {
-3 {
#index below lower bound
set pre [list]
set fidx -1
}
-2 {
#first index position is greater than index of last element in the list
set pre [lrange $l 0 end]
set fidx [llength $l]
}
default {
set pre [lrange $l 0 $first-1]
}
}
set lidx [punk::lib::lindex_resolve $l $last]
switch -exact -- $lidx {
-3 {
#index below lower bound
set post [lrange $l 0 end]
}
-2 {
#index above upper bound
set post [list]
}
default {
if {$lidx < $fidx} {
#from ledit man page:
#If last is less than first, then any specified elements will be inserted into the list before the element specified by first with no elements being deleted.
set post [lrange $l $fidx end]
} else {
set post [lrange $l $last+1 end]
}
}
}
set l [list {*}$pre {*}$args {*}$post]
}
#slight isolation - varnames don't leak - but calling context vars can be affected
@ -1137,11 +1183,13 @@ namespace eval punk::lib {
if {!$has_punk_ansi} {
set RST ""
set sep " = "
set sep_mismatch " mismatch "
#set sep_mismatch " mismatch "
set sep \u2260 ;# equivalent [punk::ansi::convert_g0 [punk::ansi::g0 |]] (not equal symbol)
} else {
set RST [punk::ansi::a]
set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support
set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST "
#set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST "
set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]\u2260$RST "
}
package require punk::pipe
#package require punk ;#we need pipeline pattern matching features
@ -1173,6 +1221,7 @@ namespace eval punk::lib {
-keysortdirection -default increasing -choices {increasing decreasing}
-debug -default 0 -type boolean -help\
"When enabled, produces some rudimentary debug output on stderr"
-- -type none -optional 1
@values -min 1 -max -1
dictvalue -type list -help\
"dict or list value"
@ -1880,6 +1929,19 @@ namespace eval punk::lib {
}
proc is_list_all_in_list {small large} {
if {[llength $small] > [llength $large]} {return 0}
foreach x $large {
::set ($x) {}
}
foreach x $small {
if {![info exists ($x)]} {
return 0
}
}
return 1
}
#v2 generally seems slower
proc is_list_all_in_list2 {small large} {
set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]]
return [struct::list equal [lsort $small] $small_in_large]
}
@ -1888,11 +1950,22 @@ namespace eval punk::lib {
package require struct::list
package require struct::set
}
append body [info body is_list_all_in_list]
proc is_list_all_in_list {small large} $body
append body [info body is_list_all_in_list2]
proc is_list_all_in_list2 {small large} $body
}
proc is_list_all_ni_list {a b} {
proc is_list_all_ni_list {A B} {
foreach x $B {
::set ($x) {}
}
foreach x $A {
if {[info exists ($x)]} {
return 0
}
}
return 1
}
proc is_list_all_ni_list2 {a b} {
set i [struct::set intersect $a $b]
return [expr {[llength $i] == 0}]
}
@ -1900,8 +1973,8 @@ namespace eval punk::lib {
set body {
package require struct::list
}
append body [info body is_list_all_ni_list]
proc is_list_all_ni_list {a b} $body
append body [info body is_list_all_ni_list2]
proc is_list_all_ni_list2 {a b} $body
}
#somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist
@ -1917,7 +1990,16 @@ namespace eval punk::lib {
}
return $result
}
#with ledit (also avail in 8.6 using punk::lib::compat::ledit
proc ldiff2 {fromlist removeitems} {
if {[llength $removeitems] == 0} {return $fromlist}
foreach item $removeitems {
set posns [lsearch -all -exact $fromlist $item]
foreach p $posns {ledit fromlist $p $p}
}
return $fromlist
}
proc ldiff3 {fromlist removeitems} {
set doomed [list]
foreach item $removeitems {
lappend doomed {*}[lsearch -all -exact $fromlist $item]
@ -2159,6 +2241,41 @@ namespace eval punk::lib {
}
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side
punk::args::define {
@id -id ::punk::lib::lindex_resolve
@cmd -name punk::lib::lindex_resolve\
-summary\
"Resolve an indexexpression to an integer based on supplied list."\
-help\
"Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2
to the actual integer index for the supplied list, or to a negative value below -1 indicating
whether the index was below or above the range of possible indices for the list.
Users may define procs which accept a list index and wish to accept the forms understood by Tcl.
This means the proc may be called with something like $x+2 end-$y etc
Sometimes the actual integer index is desired.
We want to resolve the index used, without passing arbitrary expressions into the 'expr' function
- which could have security risks.
lindex_resolve will parse the index expression and return:
a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0)
b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end)
lindex_resolve never returns -1 - as the similar function lindex_resolve_basic uses this to denote
out of range at either end of the list
Otherwise it will return an integer corresponding to the position in the list.
This is in stark contrast to Tcl list function indices which will return empty strings for out of
bounds indices, or in the case of lrange, return results anyway.
Like Tcl list commands - it will produce an error if the form of the index is not acceptable
For empty lists, end and end+x indices are considered to be out of bounds on the upper side
- thus returning -2
Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command.
We will get something like 10+1 - which can be resolved safely with expr
"
@values -min 2 -max 2
list -type list
index -type indexexpression
}
proc lindex_resolve {list index} {
#*** !doctools
#[call [fun lindex_resolve] [arg list] [arg index]]
@ -2172,11 +2289,11 @@ namespace eval punk::lib {
#[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end)
#[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list
#[para]Otherwise it will return an integer corresponding to the position in the list.
#[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway.
#[para]This is in stark contrast to Tcl list function indices which will return empty strings for out of bounds indices, or in the case of lrange, return results anyway.
#[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable
#[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2
#Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr
#Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which can be resolved safely with expr
#if {![llength $list]} {
# #review
# return ???

687
src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm
Unescape View File

@ -81,14 +81,15 @@ tcl::namespace::eval punk::libunknown {
}]
variable epoch
if {![info exists epoch]} {
set tmstate [dict create 0 {}]
set pkgstate [dict create 0 {}]
set tminfo [dict create current 0 epochs $tmstate]
set pkginfo [dict create current 0 epochs $pkgstate]
#if {![info exists epoch]} {
# set tmstate [dict create 0 {}]
# set pkgstate [dict create 0 {}]
# set tminfo [dict create current 0 epochs $tmstate]
# set pkginfo [dict create current 0 epochs $pkgstate]
# set epoch [dict create tm $tminfo pkg $pkginfo]
#}
set epoch [dict create tm $tminfo pkg $pkginfo]
}
variable has_package_files
if {[catch {package files foobaz}]} {
@ -114,6 +115,19 @@ tcl::namespace::eval punk::libunknown {
# Import the pattern used to check package names in detail.
variable epoch
set pkg_epoch [dict get $epoch tm current]
set must_scan 0
if {[dict exists $epoch tm untracked $name]} {
set must_scan 1
#a package that was in the package database at the start - is now being searched for as unknown
#our epoch info is not reliable for pre-known packages - so increment the epoch and fully clear the 'added' paths even in zipfs to do proper scan
#review
#epoch_incr_pkg clearadded
#epoch_incr_tm clearadded
#puts ">>>> removing untracked tm: $name"
dict unset epoch tm untracked $name
#whie it is not the most common configuration - a package could be provided both as a .tm and by packageIndex.tcl files
}
#variable paths
@ -151,7 +165,8 @@ tcl::namespace::eval punk::libunknown {
if {![interp issafe] && ![file exists $path]} {
continue
}
set currentsearchpath [file join $path $pkgroot]
set currentsearchpath $path
set specificsearchpath [file join $path $pkgroot]
# Get the module files out of the subdirectories.
# - Safe Base interpreters have a restricted "glob" command that
@ -162,32 +177,35 @@ tcl::namespace::eval punk::libunknown {
set use_epoch_for_all 1
if {$use_epoch_for_all || [string match $zipfsroot* $path]} {
if {[dict exists $epoch tm epochs $pkg_epoch indexes $currentsearchpath]} {
if {!$must_scan && [dict exists $epoch tm epochs $pkg_epoch indexes $specificsearchpath]} {
#indexes are actual .tm files here
set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]]
set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $specificsearchpath]]
#puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles ( cached ): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath"
} else {
if {![interp issafe] && ![file exists $currentsearchpath]} {
dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create]
if {![interp issafe] && ![file exists $specificsearchpath]} {
dict set epoch tm epochs $pkg_epoch indexes $specificsearchpath [dict create]
continue
}
dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create]
dict set epoch tm epochs $pkg_epoch indexes $specificsearchpath [dict create]
# #################################################################
if {$has_zipfs && [string match $zipfsroot* $path]} {
#The entire tm tre is available so quickly from the zipfs::list call - that we can gather all at once.
set tmfiles [::tcl::zipfs::list $currentsearchpath/*.tm] ;#could theoretically be a dir - this is effectively a tree traversal
foreach tm_path $tmfiles {
dict set epoch tm epochs $pkg_epoch indexes [file dirname $tm_path] $tm_path $pkg_epoch
}
#retrieval using tcl::zipfs::list got (and cached) extras - limit to currentsearchpath
set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]]
#retrieval using tcl::zipfs::list got (and cached) extras - limit to specificsearchpath
set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $specificsearchpath]]
} else {
set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm]
#set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm]
set tmfiles [glob -nocomplain -directory $specificsearchpath *.tm]
foreach tm_path $tmfiles {
dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath $tm_path $pkg_epoch
#dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath $tm_path $pkg_epoch
dict set epoch tm epochs $pkg_epoch indexes $specificsearchpath $tm_path $pkg_epoch
}
}
#puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles (UNcached): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath"
@ -203,8 +221,8 @@ tcl::namespace::eval punk::libunknown {
set can_skip_update 0
if {[string match $zipfsroot* $path]} {
#static tm location
if {[dict exists $epoch tm epochs $pkg_epoch added $currentsearchpath]} {
if {![dict exists $epoch tm epochs $pkg_epoch added $currentsearchpath $name]} {
if {[dict exists $epoch tm epochs $pkg_epoch added $specificsearchpath]} {
if {![dict exists $epoch tm epochs $pkg_epoch added $specificsearchpath $name]} {
#$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again.
#puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP orig:$original name:$name args:$args searchpath:$currentsearchpath"
set can_skip_update 1
@ -213,19 +231,13 @@ tcl::namespace::eval punk::libunknown {
#dict unset epoch tm epochs $pkg_epoch added $currentsearchpath $name
}
}
} else {
#dynamic - can only skip if negatively cached for the current epoch
if {[dict exists $epoch tm epochs $pkg_epoch unfound $currentsearchpath $name]} {
#puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)"
set can_skip_update 1
}
}
if {!$can_skip_update} {
set strip [llength [file split $path]]
set found_name_in_currentsearchpath 0 ;#for negative cache by epoch
catch {
if {[catch {
foreach file $tmfiles {
set pkgfilename [join [lrange [file split $file] $strip end] ::]
@ -252,6 +264,20 @@ tcl::namespace::eval punk::libunknown {
# the one we already have.
# This does not apply to Safe Base interpreters because
# the token-to-directory mapping may have changed.
#JMN - review.
#dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname [dict create e $pkg_epoch v $pkgversion]
dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname $pkgversion e$pkg_epoch
if {$must_scan} {
#however - if we know we're forced to scan all tm paths we can remove discovered sibling tms from tm untracked
dict unset epoch tm untracked $pkgname
}
if {$pkgname eq $name} {
#can occur multiple times, different versions
#record package name as found in this path whether version satisfies or not
set found_name_in_currentsearchpath 1
}
#don't override the ifneeded script - for tm files the first encountered 'wins'.
continue
}
@ -273,8 +299,15 @@ tcl::namespace::eval punk::libunknown {
"[::list package provide $pkgname $pkgversion];[::list source $file]"
#JMN
#store only once for each name, although there may be multiple versions
dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname $pkg_epoch
#store only once for each name, although there may be multiple versions of same package within this searchpath
#dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname [dict create e $pkg_epoch v $pkgversion]
dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname $pkgversion e$pkg_epoch
#pkgname here could be the 'name' passed at the beggning - or other .tms at the same location.
#we can't always remove other .tms from 'tm untracked' because the search for name might skip some locations.
if {$must_scan} {
#however - if we know we're forced to scan all tm paths we can remove discovered sibling tms from tm untracked
dict unset epoch tm untracked $pkgname
}
# We abort in this unknown handler only if we got a
# satisfying candidate for the requested package.
@ -298,10 +331,8 @@ tcl::namespace::eval punk::libunknown {
set found_name_in_currentsearchpath 1
}
}
}
if {!$found_name_in_currentsearchpath} {
#can record as unfound for this path - for this epoch
dict set epoch tm epochs $pkg_epoch unfound $currentsearchpath $name 1
} errMsg]} {
puts stderr "zipfs_tm_Unknownhandler: error for tm file $file searchpath:$currentsearchpath"
}
}
@ -380,9 +411,9 @@ tcl::namespace::eval punk::libunknown {
}
if {$satisfied} {
##return
}
#if {$satisfied} {
# return
#}
}
# Fallback to previous command, if existing. See comment above about
@ -399,6 +430,25 @@ tcl::namespace::eval punk::libunknown {
variable epoch
set pkg_epoch [dict get $epoch pkg current]
#review - the ifneeded script is not the only thing required in a new interp.. consider tclIndex files and auto_load mechanism.
#also the pkgIndex.tcl could possibly provide a different ifneeded script based on interp issafe (or other interp specific things?)
#if {[dict exists $epoch scripts $name]} {
# set vscripts [dict get $epoch scripts $name]
# dict for {v scr} $vscripts {
# puts ">package ifneeded $name $v"
# package ifneeded $name $v $scr
# }
# return
#}
set must_scan 0
if {[dict exists $epoch pkg untracked $name]} {
#a package that was in the package database at the start - is now being searched for as unknown
#(due to a package forget?)
#our epoch info is not valid for pre-known packages - so setting must_scan to true
set must_scan 1
#puts ">>>> removing pkg untracked: $name"
dict unset epoch pkg untracked $name
}
#global auto_path env
global auto_path
@ -414,7 +464,7 @@ tcl::namespace::eval punk::libunknown {
set zipfsroot [tcl::zipfs::root]
set has_zipfs 1
} else {
set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands
set zipfsroot "//zipfs:/" ;#doesn't matter too much what we use here - don't expect in tm list if no zipfs commands
set has_zipfs 0
}
@ -426,6 +476,11 @@ tcl::namespace::eval punk::libunknown {
set before_dict [dict create]
#Note that autopath is being processed from the end to the front
#ie last lappended first. This means if there are duplicate versions earlier in the list,
#they will be the last to call 'package provide' for that version and so their provide script will 'win'.
#This means we should have faster filesystems such as zipfs earlier in the list.
# Cache the auto_path, because it may change while we run through the
# first set of pkgIndex.tcl files
set old_path [set use_path $auto_path]
@ -449,7 +504,7 @@ tcl::namespace::eval punk::libunknown {
set use_epoch_for_all 1
if {$use_epoch_for_all || [string match $zipfsroot* $dir]} {
set currentsearchpath $dir
if {[dict exists $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]} {
if {!$must_scan && [dict exists $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]} {
set indexfiles [dict keys [dict get $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]]
#puts stderr "--->zipfs_tclPkgUnknown $tid llength tmfiles ( cached ): [format %4d [llength $indexfiles]] name:$name searchpath:$currentsearchpath"
} else {
@ -468,8 +523,9 @@ tcl::namespace::eval punk::libunknown {
}
set can_skip_sourcing 0
if {$has_zipfs && [string match $zipfsroot* $dir]} {
#if {$has_zipfs && [string match $zipfsroot* $dir]} {
#static auto_path dirs
if {!$must_scan} {
#can avoid scan if added via this path in any epoch
if {[dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} {
if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} {
@ -483,14 +539,11 @@ tcl::namespace::eval punk::libunknown {
#dict unset epoch pkg epochs $pkg_epoch added $currentsearchpath $name
}
}
} else {
#dynamic auto_path dirs - libs could have been added/removed
#scan unless cached negative for this epoch
if {[dict exists $epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name]} {
#puts stderr "zipfs_tclPkgUnknown $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)"
set can_skip_sourcing 1
}
}
#}
#An edge case exception is that after a package forget, a deliberate call to 'package require non-existant'
#will not trigger rescans for all versions of other packages.
#A rescan of a specific package for all versions can still be triggered with a package require for
@ -498,33 +551,47 @@ tcl::namespace::eval punk::libunknown {
#(or misordered min max e.g package require md5 1-0 i.e a deliberately unsatisfiable version range)
set sourced 0
#set sourced_files [list]
if {!$can_skip_sourcing} {
#Note - naive comparison of before_pkgs vs after_pkgs isn't quite enough to tell if something was added. It could have added a version.
#this will stop us rescanning everything properly by doing a 'package require nonexistant'
#use 'info exists' to only call package names once and then append? worth it?
#use 'info exists' to only call package names once and then append?
#This could be problematic? (re-entrant tclPkgUnknown in some pkgIndex scripts?) pkgIndex.tcl scripts "shouldn't" do this?
if {![info exists before_pkgs]} {
set before_pkgs [package names]
}
#update the before_dict which persists across while loop
#we need to track the actual 'ifneeded' script not just version numbers,
#because the last ifneeded script processed for each version is the one that ultimately applies.
foreach bp $before_pkgs {
dict set before_dict $bp [package versions $bp]
#dict set before_dict $bp [package versions $bp]
foreach v [package versions $bp] {
dict set before_dict $bp $v [package ifneeded $bp $v]
}
catch {
}
}
#set before_pkgs [package names]
#catch {
foreach file $indexfiles {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
#puts stderr "----->0 sourcing $file"
#if {[string match //zipfs* $file]} {
# puts stderr "----->0 sourcing zipfs file $file"
#}
incr sourced ;#count as sourced even if source fails; keep before actual source action
#::tcl::Pkg::source $file
#lappend sourced_files $file
tcl_Pkg_source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (1)"
continue
} on error msg {
if {[regexp {version conflict for package} $msg]} {
# In case of version conflict, silently ignore
puts stderr "zipfs_tclPkgUnknown version conflict sourcing '$file' while trying to load $name (1)\nmsg:$msg"
continue
}
tclLog "error reading package index file $file: $msg"
@ -532,8 +599,11 @@ tcl::namespace::eval punk::libunknown {
set procdDirs($dir) 1
}
}
#each source operation could affect auto_path - and thus increment the pkg epoch (via trace on ::auto_path)
#e.g tcllib pkgIndex.tcl appends to auto_path
set pkg_epoch [dict get $epoch pkg current]
}
}
#}
set dir [lindex $use_path end]
if {![info exists procdDirs($dir)]} {
set file [file join $dir pkgIndex.tcl]
@ -542,20 +612,24 @@ tcl::namespace::eval punk::libunknown {
try {
#puts "----->2 sourcing $file"
incr sourced
#lappend sourced_files $file
#::tcl::Pkg::source $file
tcl_Pkg_source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (2)"
continue
} on error msg {
if {[regexp {version conflict for package} $msg]} {
# In case of version conflict, silently ignore
puts stderr "zipfs_tclPkgUnknown version conflict sourcing '$file' while trying to load $name (2)\nmsg:$msg"
continue
}
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
set pkg_epoch [dict get $epoch pkg current]
}
}
#dict set epoch pkg epochs $pkg_epoch added $currentsearchpath [dict create]
@ -569,33 +643,85 @@ tcl::namespace::eval punk::libunknown {
set after_pkgs [package names]
set just_added [dict create]
#puts "@@@@pkg epochs $pkg_epoch searchpath:$currentsearchpath name:$name before: [llength $before_pkgs] after: [llength $after_pkgs]"
if {[llength $after_pkgs] > [llength $before_pkgs]} {
foreach a $after_pkgs {
if {![dict exists $before_dict $a]} {
dict set just_added $a 1
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $pkg_epoch
foreach v [package versions $a] {
if {![dict exists $before_dict $a $v]} {
dict set just_added $a $v 1
#dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a [dict create e $pkg_epoch v $v]
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $v e$pkg_epoch
if {$must_scan} {
dict unset epoch pkg untracked $a
}
}
}
}
#puts stderr ">>>zipfs_tclPkgUnknown added [llength $added_pkgs]"
#puts stderr ">>> [join [lrange $added_pkgs 0 10] \n]..."
}
dict for {bp bpversions} $before_dict {
if {[dict exists $just_added $bp]} {
#-----------------
#if {[dict size $just_added]} {
# puts stderr "\x1b\[31m>>>zipfs_tclPkgUnknown called on name:$name added [dict size $just_added] from searchpath:$currentsearchpath\x1b\[m"
# puts stderr ">>> [join [lrange [dict keys $just_added] 0 10] \n]..."
#} else {
# tclLog ">>>zipfs_tclPkgUnknown called on name:$name Nothing added for searchpath:$currentsearchpath"
# if {[string match twapi* $name]} {
# tclLog ">>>zipfs_tclPkgUnknown: sourced_files:"
# foreach f $sourced_files {
# puts ">>> $f"
# }
# }
# if {$currentsearchpath in "//zipfs:/app //zipfs:/app/tcl_library"} {
# puts " before_pkgs: [llength $before_pkgs]"
# puts " lsearch msgcat: [lsearch $before_pkgs msgcat]"
# puts " after_pkgs: [llength $after_pkgs]"
# puts " \x1b\31mlsearch msgcat: [lsearch $after_pkgs msgcat]\x1b\[m"
# if {[lsearch $after_pkgs msgcat] >=0} {
# set versions [package versions msgcat]
# puts "msgcat versions: $versions"
# foreach v $versions {
# puts "\x1b\[32m $v ifneeded: [package ifneeded msgcat $v] \x1b\[m"
# }
# }
# }
#}
#-----------------
#review - just because this searchpath didn't add a package or add a version for the package
#it doesn't mean there wasn't a version of this package supplied there
#It may just be the same version as one we've already found.
#The last one found (earlier in auto_path) for a version is the one that supplies the final 'package provide' statement (by overriding it)
#
dict for {bp bpversionscripts} $before_dict {
if {!$must_scan && ![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $bp]} {
#puts -nonewline .
continue
}
if {[llength $bpversions] != [llength [package versions $bp]]} {
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $pkg_epoch
dict for {bv bscript} $bpversionscripts {
set nowscript [package ifneeded $bp $bv]
if {$bscript ne $nowscript} {
#ifneeded script has changed. The same version of bp was supplied on this path.
#As it's processed later - it will be the one in effect.
#dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp [dict create e $pkg_epoch v $bv]
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $bv e$pkg_epoch
dict set before_dict $bp $bv $nowscript
if {$must_scan} {
dict unset epoch pkg untracked $bp
}
}
}
#puts stderr "zipfs_tclPkgUnknown $tid sourced: $sourced (under path: $currentsearchpath)"
if {$name ni $after_pkgs} {
#cache negative result (for this epoch only)
dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1
} elseif {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} {
dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1
}
lappend before_pkgs {*}[dict keys $just_added]
#update before_pkgs & before_dict for next path
dict for {newp vdict} $just_added {
if {$newp ni $before_pkgs} {
lappend before_pkgs $newp
}
dict for {v _} $vdict {
set nowscript [package ifneeded $newp $v]
dict set before_dict $newp $v $nowscript
}
}
}
}
@ -683,17 +809,82 @@ tcl::namespace::eval punk::libunknown {
}
#puts "zipfs_tclPkgUnknown DONE"
}
variable last_auto_path
variable last_tm_paths
proc epoch_incr_pkg {args} {
if {[catch {
variable last_auto_path
global auto_path
upvar ::punk::libunknown::epoch epoch
dict set epoch scripts {}
set prev_e [dict get $epoch pkg current]
set current_e [expr {$prev_e + 1}]
# -------------
#puts stderr "--> pkg epoch $prev_e -> $current_e"
#puts stderr "args: $args"
#puts stderr "last_auto: $last_auto_path"
#puts stderr "auto_path: $auto_path"
# -------------
if {[llength $auto_path] > [llength $last_auto_path] && [punk::libunknown::lib::is_list_all_in_list $last_auto_path $auto_path]} {
#The auto_path changed, and is a pure addition of entry/entries
#commonly this is occurs where a single entry is added by a pkgIndex.Tcl
#e.g tcllib adds its base dir so that all pkgIndex.tcl files in subdirs are subsequently found
#consider autopath
#c:/libbase //zipfs:/app/libbase
#if both contain a tcllib folder with pkgIndex.tcl that extends auto_path, the auto_path extends as follows:
# -> c:/libbase //zipfs:/app/libbase //zipfs:/app/libbase/tcllib
# -> c:/libbase //zipfs:/app/libbase //zipfs:/app/libbase/tcllib c:/libbase/tcllib
#the tclPkgUnknown usedir loop (working from end of list towards beginning) will process these changes the first time dynamically
#as they occur:
#ie //zipfs:/app/libbase //zipfs:/app/libbase/tcllib c:/libbase c:/libbase/tcllib
#A subsequent scan by tclPkgUnknown on the extended auto_path would process in the order:
#c:/libbase/tcllib c:/libbase //zipfs:/app/libbase/tcllib //zipfs:/app/libbase
#re-order the new additions to come immediately following the longest common prefix entry
set newitems [punk::libunknown::lib::ldiff $auto_path $last_auto_path]
set update $last_auto_path
#no ledit or punk::lib::compat::ledit for 8.6 - so use linsert
foreach new $newitems {
set offset 0
set has_prefix 0
foreach ap [lreverse $update] {
if {[string match $ap* $new]} {
set has_prefix 1
break
}
incr offset
}
if {$has_prefix} {
set update [linsert $update end-$offset $new]
} else {
lappend update $new
}
}
set auto_path $update
}
#else - if auto_path change wasn't just extra entries - leave as user specified
#review.
set last_auto_path $auto_path
# -------------
dict set epoch pkg current $current_e
dict set epoch pkg epochs $current_e [dict create]
if {[dict exists $epoch pkg epochs $prev_e indexes]} {
#bring across the previous indexes records if static filesystem (zipfs)
if {[info commands ::tcl::zipfs::root] ne ""} {
set has_zipfs 1
} else {
set has_zipfs 0
}
if {[dict exists $epoch pkg epochs $prev_e indexes]} {
#bring across each previous 'indexes' record *if* searchpath is within zipfs root static filesystem
# and searchpath is still a path below an auto_path entry.
if {$has_zipfs} {
set zroot [zipfs root]
dict for {searchpath indexfiles} [dict get $epoch pkg epochs $prev_e indexes] {
if {[string match $zroot* $searchpath]} {
@ -710,6 +901,9 @@ tcl::namespace::eval punk::libunknown {
}
}
}
#----------------------------------------
#store basic stats for previous epoch instead of all data.
set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e indexes]]
set index_count 0
dict for {searchpath indexfiles} [dict get $epoch pkg epochs $prev_e indexes] {
@ -718,12 +912,28 @@ tcl::namespace::eval punk::libunknown {
}
dict set epoch pkg epochs $prev_e indexes_history [dict create searchpath_count $index_searchpath_count index_count $index_count]
dict unset epoch pkg epochs $prev_e indexes
#----------------------------------------
} else {
dict set epoch pkg epochs $prev_e indexes_history [dict create searchpath_count 0 index_count 0]
}
if {[dict exists $epoch pkg epochs $prev_e added]} {
#bring across - each lib will have previous epoch number
dict set epoch pkg epochs $current_e added [dict get $epoch pkg epochs $prev_e added]
if {"clearadded" in $args} {
dict set epoch pkg epochs $current_e added [dict create]
} else {
if {$has_zipfs} {
set zroot [zipfs root]
set prev_added [dict get $epoch pkg epochs $prev_e added]
set keep_added [dict filter $prev_added key $zroot*]
#bring across - each lib will have previous epoch number as the value indicating epoch in which it was found
#dict set epoch pkg epochs $current_e added [dict get $epoch pkg epochs $prev_e added]
dict set epoch pkg epochs $current_e added $keep_added
} else {
dict set epoch pkg epochs $current_e added [dict create]
}
}
#store basic stats for previous epoch
#------------------------------------
set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e added]]
set lib_count 0
dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e added] {
@ -735,37 +945,31 @@ tcl::namespace::eval punk::libunknown {
}
dict set epoch pkg epochs $prev_e added_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count]
dict unset epoch pkg epochs $prev_e added
#------------------------------------
} else {
dict set epoch pkg epochs $prev_e added_history [dict create searchpath_count 0 lib_count 0]
}
if {[dict exists $epoch pkg epochs $prev_e unfound]} {
set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e unfound]]
set lib_count 0
dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e unfound] {
dict for {lib e} $libinfo {
if {$e == $prev_e} {
incr lib_count
}
}
}
dict set epoch pkg epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count]
dict unset epoch pkg epochs $prev_e unfound
}
} errM]} {
puts stderr "epoch_incr_pkg error\n $errM"
puts stderr "epoch_incr_pkg error\n $errM\n$::errorInfo"
}
}
proc epoch_incr_tm {args} {
if {[catch {
upvar ::punk::libunknown::epoch epoch
dict set epoch scripts {}
set prev_e [dict get $epoch tm current]
set current_e [expr {$prev_e + 1}]
dict set epoch tm current $current_e
dict set epoch tm epochs $current_e [dict create]
set tmlist [tcl::tm::list]
if {[info commands ::tcl::zipfs::root] ne ""} {
set has_zipfs 1
} else {
set has_zipfs 0
}
if {[dict exists $epoch tm epochs $prev_e indexes]} {
#bring across the previous indexes records if static filesystem (zipfs)
if {[info commands ::tcl::zipfs::root] ne ""} {
if {$has_zipfs} {
set zroot [zipfs root]
dict for {searchpath indexfiles} [dict get $epoch tm epochs $prev_e indexes] {
if {[string match $zroot* $searchpath]} {
@ -795,8 +999,21 @@ tcl::namespace::eval punk::libunknown {
dict set epoch tm epochs $prev_e indexes_history [dict create searchpath_count 0 index_count 0]
}
if {[dict exists $epoch tm epochs $prev_e added]} {
#todo? cycle through non-statics and add pkgs to pkg untracked if we are deleting 'added' records?
if {"clearadded" in $args} {
dict set epoch tm epochs $current_e added [dict create]
} else {
#bring across - each lib will have previous epoch number
dict set epoch tm epochs $current_e added [dict get $epoch tm epochs $prev_e added]
#dict set epoch tm epochs $current_e added [dict get $epoch tm epochs $prev_e added]
if {$has_zipfs} {
set zroot [zipfs root]
dict set epoch tm epochs $current_e added [dict filter [dict get $epoch tm epochs $prev_e added] key $zroot*]
} else {
dict set epoch tm epochs $current_e added [dict create]
}
}
set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e added]]
set lib_count 0
dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e added] {
@ -811,26 +1028,77 @@ tcl::namespace::eval punk::libunknown {
} else {
dict set epoch tm epochs $prev_e added_history [dict create searchpath_count 0 lib_count 0]
}
if {[dict exists $epoch tm epochs $prev_e unfound]} {
set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e unfound]]
set lib_count 0
dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e unfound] {
dict for {lib e} $libinfo {
if {$e == $prev_e} {
incr lib_count
} errM]} {
puts stderr "epoch_incr_tm error\n $errM"
}
}
#see what basic info we can gather *quickly* about the indexes for each version of a pkg that the package db knows about.
#we want no calls out to the actual filesystem - but we can use some 'file' calls such as 'file dirname', 'file split' (review -safe interp problem)
#in practice the info is only available for tm modules
proc packagedb_indexinfo {pkg} {
if {[string match ::* $pkg]} {
error "packagedb_indexinfo: package name required - not a fully qualified namespace beginning with :: Received:'$pkg'"
}
dict set epoch tm epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count]
dict unset epoch tm epochs $prev_e unfound
set versions [package versions $pkg]
if {[llength $versions] == 0} {
set v [package provide $pkg]
}
} errM]} {
puts stderr "epoch_incr_tm error\n $errM"
set versionlist [list]
foreach v $versions {
set ifneededscript [package ifneeded $pkg $v]
if {[string trim $ifneededscript] eq ""} {
lappend versionlist [list $v type unknown index "" indexbase ""]
continue
}
set scriptlines [split $ifneededscript \n]
if {[llength $scriptlines] > 1} {
lappend versionlist [list $v type unknown index "" indexbase ""]
continue
}
if {[catch {llength $ifneededscript}]} {
#scripts aren't necessarily 'list shaped' - we don't want to get into the weeds trying to make sense of arbitrary scripts.
lappend versionlist [list $v type unknown index "" indexbase ""]
continue
}
if {[lindex $ifneededscript 0] eq "package" && [lindex $ifneededscript 1] eq "provide" && [file extension [lindex $ifneededscript end]] eq ".tm"} {
set tmfile [lindex $ifneededscript end]
set nspath [namespace qualifiers $pkg]
if {$nspath eq ""} {
set base [file dirname $tmfile]
} else {
set nsparts [string map {:: " "} $nspath] ;#*naive* split - we are assuming (fairly reasonably) there are no namespaces containing spaces for a .tm module
set pathparts [file split [file dirname $tmfile]]
set baseparts [lrange $pathparts 0 end-[llength $nsparts]]
set base [file join {*}$baseparts]
}
lappend versionlist [list $v type tm index $tmfile indexbase $base script $ifneededscript]
} else {
#we could guess at the pkgindex.tcl file used based on simple pkg ifneeded scripts .tcl path compared to ::auto_index
#but without hitting filesystem to verify - it's unsatisfactory
lappend versionlist [list $v type unknown index "" indexbase "" script $ifneededscript]
}
}
return $versionlist
}
proc init {args} {
variable last_auto_path
set last_auto_path [set ::auto_path]
variable last_tm_paths
set last_tm_paths [set ::tcl::tm::paths]
set callerposn [lsearch $args -caller]
if {$callerposn > -1} {
set caller [lindex $args $callerposn+1]
puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller\x1b\[m"
#puts stderr "punk::libunknown::init auto_path : $::auto_path"
#puts stderr "punk::libunknown::init tcl::tm::list: [tcl::tm::list]"
}
proc init {} {
if {[catch {tcl::tm::list} tmlist]} {
set tmlist [list]
}
@ -850,10 +1118,113 @@ tcl::namespace::eval punk::libunknown {
#This is far from conclusive - there may be other renamers (e.g commandstack)
return
}
if {[info commands ::punk::libunknown::package] ne ""} {
puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]"
return
}
variable epoch
if {![info exists epoch]} {
set tmstate [dict create 0 {added {}}]
set pkgstate [dict create 0 {added {}}]
set tminfo [dict create current 0 epochs $tmstate untracked [dict create]]
set pkginfo [dict create current 0 epochs $pkgstate untracked [dict create]]
set epoch [dict create scripts {} tm $tminfo pkg $pkginfo]
#untracked: package names at time of punk::libunknown::init call - or passed with epoch when sharing epoch to another interp.
#The epoch state will need to be incremented and cleared of any 'added' records if any of these are requested during a package unknown call
#Because they were loaded prior to us tracking the epochs - and without trying to examine the ifneeded scripts we don't know the exact paths
#which were scanned to load them. Our 'added' key entries will not contain them because they weren't unknown
} else {
#we're accepting a pre-provided 'epoch' record (probably from another interp)
#the tm untracked and pkg untracked dicts indicate for which packages the pkg added, tm added etc data are not conclusive
#test
#todo?
}
#upon first libunknown::init in the interp, we need to add any of this interp's already known packages to the (possibly existing) tm untracked and pkg untracked dicts.
#(unless we can use packagedb_indexinfo to determine what was previously scanned?)
# review - what if the auto_path or tcl::tm::list was changed between initial scan and call of libunknown::init???
# This is likely a common scenario?!!!
# For now this is a probable flaw in the logic - we need to ensure libunknown::init is done first thing
# or suffer additional scans.. or document ??
#ideally init should be called in each interp before any scans for packages so that the list of untracked is minimized.
set pkgnames [package names]
foreach p $pkgnames {
if {[string tolower $p] in {punk::libunknown tcl::zlib tcloo tcl::oo tcl}} {
continue
}
set versions [package versions $p]
if {[llength $versions] == 0} {
continue
}
set versionlist [packagedb_indexinfo $p]
if {[llength $versionlist] == 0} {
continue
} else {
foreach vdata $versionlist {
#dict set epoch scripts $p [lindex $vdata 0] [package ifneeded $p [lindex $vdata 0]]
dict set epoch scripts $p [lindex $vdata 0] [lindex $vdata 8]]
}
if {[lsearch -index 6 $versionlist ""] > -1} {
#There exists at least one empty indexbase for this package - we have to treat it as untracked
dict set epoch tm untracked $p "" ;#value unimportant
dict set epoch pkg untracked $p "" ;#value unimportant
} else {
#update the epoch info with where the tm versions came from
#(not tracking version numbers in epoch - just package to the indexbase)
foreach vdata $versionlist {
lassign $vdata v _t type _index index _indexbase indexbase
if {$type eq "tm"} {
if {![dict exists $epoch tm epochs 0 added $indexbase]} {
#dict set epoch tm epochs 0 added $indexbase [dict create $p [dict create e 0 v $v]]
dict set epoch tm epochs 0 added $indexbase $p $v e0
} else {
set idxadded [dict get $epoch tm epochs 0 added $indexbase]
#dict set idxadded $p [dict create e 0 v $v]
dict set idxadded $p $v e0
dict set epoch tm epochs 0 added $indexbase $idxadded
}
dict unset epoch tm untracked $p
} elseif {$type eq "pkg"} {
#todo? tcl doesn't give us good introspection on package indexes for packages
#dict unset epoch pkg untracked $p
}
}
}
}
}
#-------------------------------------------------------------
#set all_untracked [dict keys [dict get $epoch untracked]]
#puts stderr "\x1b\[1\;33m punk::libunknown::init - pkg all_untracked:\x1b\[m [dict size [dict get $epoch pkg untracked]]"
#if {[dict exists $epoch pkg untracked msgcat]} {
# puts stderr "\x1b\[1\;32m punk::libunknown::init msgcat found in pkg untracked \x1b\[m "
# set versions [package versions msgcat]
# puts stderr "versions: $versions"
# foreach v $versions {
# puts stdout "v $v ifneeded: [package ifneeded msgcat $v]"
# }
#} else {
# puts stderr "\x1b\[1\;31m punk::libunknown::init msgcat NOT found in pkg untracked \x1b\[m "
#}
#puts stderr "\x1b\[1\;33m punk::libunknown::init - tm all_untracked:\x1b\[m [dict size [dict get $epoch tm untracked]]"
#if {[dict exists $epoch tm untracked msgcat]} {
# puts stderr "\x1b\[1\;32m punk::libunknown::init msgcat found in tm untracked \x1b\[m "
# set versions [package versions msgcat]
# puts stderr "versions: $versions"
# foreach v $versions {
# puts stdout "v $v ifneeded: [package ifneeded msgcat $v]"
# }
#} else {
# puts stderr "\x1b\[1\;31m punk::libunknown::init msgcat NOT found in tm untracked \x1b\[m "
#}
#-------------------------------------------------------------
trace add variable ::auto_path write ::punk::libunknown::epoch_incr_pkg
trace add variable ::tcl::tm::paths write ::punk::libunknown::epoch_incr_tm
@ -870,6 +1241,7 @@ tcl::namespace::eval punk::libunknown {
#forgetting Tcl or tcl seems to be a bad idea - package require doesn't work afterwards (independent of this pkg)
set forgets_requested [lrange $args 1 end]
set ok_forgets [list]
upvar ::punk::libunknown::epoch epoch
foreach p $forgets_requested {
#'package files' not avail in early 8.6
#There can be other custom 'package ifneeded' scripts that don't use source - but still need to be forgotten.
@ -880,7 +1252,7 @@ tcl::namespace::eval punk::libunknown {
# lappend ok_forgets $p
#}
#What then? Hardcoded only for now?
if {$p ni {tcl Tcl tcl::oo}} {
if {$p ni {tcl Tcl tcl::oo tk}} {
#tcl::oo returns a comment only for its package provide script "# Already present, OK?"
# - so we can't use empty 'ifneeded' script as a determinant.
set vpresent [package provide $p]
@ -890,11 +1262,13 @@ tcl::namespace::eval punk::libunknown {
set ifneededscript [package ifneeded $p $vpresent]
if {[string trim $ifneededscript] ne ""} {
lappend ok_forgets $p
dict unset epoch scripts $p
}
} else {
#not loaded - but may have registered ifneeded script(s) in the package database
#assume ok to forget
lappend ok_forgets $p
dict unset epoch scripts $p
}
}
}
@ -1030,11 +1404,122 @@ tcl::namespace::eval punk::libunknown {
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
}
proc package_query {pkgname} {
variable epoch
if {[dict exists $epoch tm untracked $pkgname]} {
set pkg_info "$pkgname tm UNTRACKED"
} else {
set pkg_info "$pkgname not in tm untracked"
}
if {[dict exists $epoch pkg untracked $pkgname]} {
append pkg_info \n "$pkgname pkg UNTRACKED"
} else {
append pkg_info \n "$pkgname not in pkg untracked"
}
set pkg_epoch [dict get $epoch pkg current]
#set epoch_info [dict get $epoch pkg epochs $pkg_epoch]
#pkg entries are processed by package unknown in reverse - so their order of creaation is opposite to ::auto_path
set r_added [dict create]
foreach path [lreverse [dict keys [dict get $epoch pkg epochs $pkg_epoch added]]] {
dict set r_added $path [dict get $epoch pkg epochs $pkg_epoch added $path]
}
#set pkg_added [punk::lib::showdict [dict get $epoch pkg epochs $pkg_epoch added] */$pkgname]
set pkg_added [punk::lib::showdict $r_added */$pkgname]
set title "PKG epoch $pkg_epoch - added"
set added [textblock::frame -title $title $pkg_added]
set pkg_row $added
set tm_epoch [dict get $epoch tm current]
set tm_added [punk::lib::showdict [dict get $epoch tm epochs $tm_epoch added] */$pkgname]
set title "TM epoch $tm_epoch - added"
set added [textblock::frame -title $title $tm_added]
set tm_row $added
return $pkg_info\n$pkg_row\n$tm_row
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::libunknown ---}]
}
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::libunknown::lib {
#A version of textutil::string::longestCommonPrefixList
#(also as ::punk::lib::longestCommonPrefixList)
proc longestCommonPrefix {items} {
if {[llength $items] <= 1} {
return [lindex $items 0]
}
set items [lsort $items[unset items]]
set min [lindex $items 0]
set max [lindex $items end]
#if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list)
#(sort order nothing to do with length - e.g min may be longer than max)
if {[string length $min] > [string length $max]} {
set temp $min
set min $max
set max $temp
}
set n [string length $min]
set prefix ""
set i -1
while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} {
append prefix $c
}
return $prefix
}
#maint: from punk::lib::ldiff
proc ldiff {fromlist removeitems} {
if {[llength $removeitems] == 0} {return $fromlist}
set result [list]
foreach item $fromlist {
if {$item ni $removeitems} {
lappend result $item
}
}
return $result
}
proc intersect2 {A B} {
#taken from tcl version of struct::set::Intersect
if {[llength $A] == 0} {return {}}
if {[llength $B] == 0} {return {}}
# This is slower than local vars, but more robust
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
}
proc is_list_all_in_list {A B} {
if {[llength $A] > [llength $B]} {return 0}
foreach x $B {
::set ($x) {}
}
foreach x $A {
if {![info exists ($x)]} {
return 0
}
}
return 1
}
}
# -----------------------------------------------------------------------------
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked

9
src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm
Unescape View File

@ -77,6 +77,12 @@ namespace eval punk::mix::commandset::module {
return $result
}
#require current dir when calling to be the projectdir, or
punk::args::define {
@dynamic
@id -id "::punk::mix::commandset::module::templates"
@cmd -name "punk::mix::commandset::module::templates"
${[punk::args::resolved_def -antiglobs {@id @cmd} "::punk::mix::commandset::module::templates_dict"]}
}
proc templates {args} {
set tdict_low_to_high [templates_dict {*}$args]
#convert to screen order - with higher priority at the top
@ -135,7 +141,8 @@ namespace eval punk::mix::commandset::module {
globsearches -default * -multiple 1
}
proc templates_dict {args} {
set argd [punk::args::get_by_id ::punk::mix::commandset::module::templates_dict $args]
#set argd [punk::args::get_by_id ::punk::mix::commandset::module::templates_dict $args]
set argd [punk::args::parse $args withid ::punk::mix::commandset::module::templates_dict]
package require punk::cap
if {[punk::cap::capability_has_handler punk.templates]} {
set template_folder_dict [punk::cap::call_handler punk.templates get_itemdict_moduletemplates {*}$args]

3
src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm
Unescape View File

@ -940,7 +940,8 @@ tcl::namespace::eval punk::nav::fs {
#windows doesn't consider dotfiles as hidden - mac does (?)
#we add dotfiles to flaggedhidden list in case there is some other mechanism that has flagged items as hidden
if {$::tcl_platform(platform) ne "windows"} {
lappend flaggedhidden {*}[lsearch -all -inline [list {*}$dirs {*}$files] ".*"]
#lappend flaggedhidden {*}[lsearch -all -inline [list {*}$dirs {*}$files] ".*"]
lappend flaggedhidden {*}[tcl::prefix::all [list {*}$dirs {*}$files] .]
#e.g we can have dupes in the case where there are vfs mounted files that appear as dirs
#as we will need to do a (nat)sort as a last step - it will be faster to not sort items prematurely
#set flaggedhidden [lsort -unique $flaggedhidden]

142
src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm
Unescape View File

@ -408,6 +408,7 @@ tcl::namespace::eval punk::ns {
proc nstail {nspath args} {
#normalize the common case of ::::
set nspath [string map {:::: ::} $nspath]
#it's unusual - but namespaces *can* have spaced in them.
set mapped [string map {:: \u0FFF} $nspath]
set parts [split $mapped \u0FFF]
@ -1423,7 +1424,7 @@ tcl::namespace::eval punk::ns {
}
}
return $matches
}]
}]]
} else {
lappend matched {*}[tcl::namespace::eval $location [list ::info commands [nsjoin ${location} $p]]]
@ -2397,14 +2398,16 @@ tcl::namespace::eval punk::ns {
if {$is_ensembleparam} {
#review
lappend nextqueryargs $q
lpop queryargs_untested 0
#lpop queryargs_untested 0
ledit queryargs_untested 0 0
set specargs $queryargs_untested
continue
}
if {![llength $allchoices]} {
#review - only leaders with a defined set of choices are eligible for consideration as a subcommand
lappend nextqueryargs $q
lpop queryargs_untested 0
#lpop queryargs_untested 0
ledit queryargs_untested 0 0
set specargs $queryargs_untested
continue
}
@ -2420,7 +2423,8 @@ tcl::namespace::eval punk::ns {
}
lappend nextqueryargs $resolved_q
lpop queryargs_untested 0
#lpop queryargs_untested 0
ledit queryargs_untested 0 0
if {$resolved_q ne $q} {
#we have our first difference - recurse with new query args
set resolvelist [list {*}$specid {*}$nextqueryargs {*}$queryargs_untested]
@ -2510,8 +2514,12 @@ tcl::namespace::eval punk::ns {
punk::args::define {
@id -id ::punk::ns::forms
@cmd -name punk::ns::forms -help\
"Return names for each form of a command"
@cmd -name punk::ns::forms\
-summary\
"List command forms."\
-help\
"Return names for each form of a command.
Most commands are single-form and will only return the name '_default'."
@opts
@values -min 1 -max -1
cmditem -multiple 1 -optional 0
@ -2523,12 +2531,37 @@ tcl::namespace::eval punk::ns {
set id [dict get $cmdinfo origin]
::punk::args::forms $id
}
punk::args::define {
@id -id ::punk::ns::eg
@cmd -name punk::ns::eg\
-summary\
"Return command examples."\
-help\
"Return the -help info from the @examples directive
in a command definition."
@values -min 1 -max -1
cmditem -multiple 1 -optional 0
}
proc eg {args} {
set argd [::punk::args::parse $args withid ::punk::ns::eg]
set cmdmembers [dict get $argd values cmditem]
set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context
set resolved_id [dict get $cmdinfo origin]
set result [::punk::args::eg $resolved_id]
}
punk::args::define {
@id -id ::punk::ns::synopsis
@cmd -name punk::ns::synopsis -help\
@cmd -name punk::ns::synopsis\
-summary\
"Return command synopsis."\
-help\
"Return synopsis for each form of a command
on separate lines.
If -form <formname> is given, supply only
If -form formname|<int> is given, supply only
the synopsis for that form.
"
@opts
@ -2564,9 +2597,13 @@ tcl::namespace::eval punk::ns {
full - summary {
set resultstr ""
foreach synline [split $syn \n] {
if {[string range $synline 0 1] eq "# "} {
append resultstr $synline \n
} else {
#append resultstr [join [lreplace $synline 0 0 {*}$idparts] " "] \n
append resultstr [join [lreplace $synline 0 [llength $resolved_id]-1 {*}$idparts] " "] \n
}
}
set resultstr [string trimright $resultstr \n]
#set resultstr [join [lreplace $syn 0 0 {*}$idparts] " "]
return $resultstr
@ -2591,7 +2628,10 @@ tcl::namespace::eval punk::ns {
punk::args::define {
@dynamic
@id -id ::punk::ns::arginfo
@cmd -name punk::ns::arginfo -help\
@cmd -name punk::ns::arginfo\
-summary\
"Command usage/help."\
-help\
"Show usage info for a command.
It supports the following:
1) Procedures or builtins for which a punk::args definition has
@ -2618,6 +2658,9 @@ tcl::namespace::eval punk::ns {
} {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} {
-form -default 0 -help\
"Ordinal index or name of command form"
-grepstr -default "" -type list -typesynopsis regex -help\
"list consisting of regex, optionally followed by ANSI names for highlighting
(incomplete - todo)"
-- -type none -help\
"End of options marker
Use this if the command to view begins with a -"
@ -2642,6 +2685,8 @@ tcl::namespace::eval punk::ns {
set querycommand [dict get $values commandpath]
set queryargs [dict get $values subcommand]
set grepstr [dict get $opts -grepstr]
set opts [dict remove $opts -grepstr]
#puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'"
#todo - similar to corp? review corp resolution process
@ -2905,7 +2950,8 @@ tcl::namespace::eval punk::ns {
break
}
lappend nextqueryargs $resolved_q
lpop queryargs_untested 0
#lpop queryargs_untested 0
ledit queryargs_untested 0 0
if {$resolved_q ne $q} {
#we have our first difference - recurse with new query args
#set numvals [expr {[llength $queryargs]+1}]
@ -3020,8 +3066,11 @@ tcl::namespace::eval punk::ns {
set arglist [lindex $constructorinfo 0]
set argdef [punk::lib::tstr -return string {
@id -id "(autodef)${$origin} new"
@cmd -name "${$origin} new" -help\
"create object with specified command name.
@cmd -name "${$origin} new"\
-summary\
"Create new object instance."\
-help\
"create object with autogenerated command name.
Arguments are passed to the constructor."
@values
}]
@ -3071,7 +3120,10 @@ tcl::namespace::eval punk::ns {
set arglist [lindex $constructorinfo 0]
set argdef [punk::lib::tstr -return string {
@id -id "(autodef)${$origin} create"
@cmd -name "${$origin} create" -help\
@cmd -name "${$origin} create"\
-summary\
"Create new object instance with specified command name."\
-help\
"create object with specified command name.
Arguments following objectName are passed to the constructor."
@values -min 1
@ -3124,7 +3176,10 @@ tcl::namespace::eval punk::ns {
# but we may want notes about a specific destructor
set argdef [punk::lib::tstr -return string {
@id -id "(autodef)${$origin} destroy"
@cmd -name "destroy" -help\
@cmd -name "destroy"\
-summary\
"delete object instance."\
-help\
"delete object, calling destructor if any.
destroy accepts no arguments."
@values -min 0 -max 0
@ -3601,6 +3656,13 @@ tcl::namespace::eval punk::ns {
set msg "Undocumented command $origin. Type: $cmdtype"
}
}
if {[llength $grepstr] != 0} {
if {[llength $grepstr] == 1} {
return [punk::grepstr -no-linenumbers -highlight red [lindex $grepstr 0] $msg]
} else {
return [punk::grepstr -no-linenumbers -highlight [lrange $grepstr 1 end] [lindex $grepstr 0] $msg]
}
}
return $msg
}
@ -3799,13 +3861,53 @@ tcl::namespace::eval punk::ns {
}
punk::args::define {
@id -id ::punk::ns::pkguse
@cmd -name punk::ns::pkguse -help\
"Load package and move to namespace of the same name if run
interactively with only pkg/namespace argument.
if script and args are supplied, the
script runs in the namespace with the args passed to the script.
todo - further documentation"
@leaders -min 1 -max 1
pkg_or_existing_ns -type string
@opts
-vars -type none -help\
"whether to capture namespace vars for use in the supplied script"
-nowarnings -type none
@values -min 0 -max -1
script -type string -optional 1
arg -type any -optional 1 -multiple 1
}
#load package and move to namespace of same name if run interactively with only pkg/namespace argument.
#if args is supplied - first word is script to run in the namespace remaining args are args passed to scriptblock
#if no newline or $args in the script - treat as one-liner and supply {*}$args automatically
proc pkguse {pkg_or_existing_ns args} {
lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs
set use_vars [expr {"-vars" in $runopts}]
set no_warnings [expr {"-nowarnings" in $runopts}]
proc pkguse {args} {
set argd [punk::args::parse $args withid ::punk::ns::pkguse]
lassign [dict values $argd] leaders opts values received
puts stderr "leaders:$leaders opts:$opts values:$values received:$received"
set pkg_or_existing_ns [dict get $leaders pkg_or_existing_ns]
if {[dict exists $received script]} {
set scriptblock [dict get $values script]
} else {
set scriptblock ""
}
if {[dict exists $received arg]} {
set arglist [dict get $values arg]
} else {
set arglist [list]
}
set use_vars [dict exists $received "-vars"]
set no_warnings [dict exists $received "-nowarnings"]
#lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs
#set use_vars [expr {"-vars" in $runopts}]
#set no_warnings [expr {"-nowarnings" in $runopts}]
set ver ""
@ -3883,7 +3985,7 @@ tcl::namespace::eval punk::ns {
}
}
if {[tcl::namespace::exists $ns]} {
if {[llength $cmdargs]} {
if {[dict exists $received script]} {
set binding {}
#if {[info level] == 1} {
# #up 1 is global
@ -3923,7 +4025,7 @@ tcl::namespace::eval punk::ns {
} ]
set arglist [lassign $cmdargs scriptblock]
#set arglist [lassign $cmdargs scriptblock]
if {[string first "\n" $scriptblock] <0 && [string first {$args} $scriptblock] <0} {
#one liner without use of $args
append scriptblock { {*}$args}

60
src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm
Unescape View File

@ -110,9 +110,9 @@ tcl::namespace::eval punk::packagepreference {
#[list_begin definitions]
lappend PUNKARGS [list {
@id -id ::punk::packagepreference::install
@cmd -name ::punk::packagepreference::install -help\
"Install override for ::package builtin - for 'require' subcommand only."
@id -id ::punk::packagepreference::uninstall
@cmd -name ::punk::packagepreference::uninstall -help\
"Uninstall override for ::package builtin - for 'require' subcommand only."
@values -min 0 -max 0
}]
proc uninstall {} {
@ -238,18 +238,64 @@ tcl::namespace::eval punk::packagepreference {
}
}
# ---------------------------------------------------------------
set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
#??
#set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
if {[regexp {[A-Z]} $pkg]} {
#legacy package names
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation
if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} {
return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
try {
set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant]
} trap {} {emsg eopts} {
return -options $eopts $emsg
}
} else {
return $v
set require_result $v
}
} else {
return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
#return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
try {
set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant]
} trap {} {emsg eopts} {
return -options $eopts $emsg
}
}
#---------------------------------------------------------------
#load relevant punk::args::<docname> package(s)
#todo - review whether 'packagepreference' is the right place for this.
#It is conceptually different from the main functions of packagepreference,
#but we don't really want to have a chain of 'package' overrides slowing performance.
#there may be a more generic way to add soft side-dependencies that the original package doesn't/can't specify.
#---------------------------------------------------------------
set lc_pkg [string tolower $pkg]
#todo - lookup list of docpkgs for a package? from where?
#we should have the option to not load punk::args::<docpkg> at all for many(most?) cases where they're unneeded.
#e.g skip if not ::tcl_interactive?
switch -exact -- $lc_pkg {
tcl {
set docpkgs [list tclcore]
}
tk {
set docpkgs [list tkcore]
}
default {
set docpkgs [list $lc_pkg]
}
}
foreach dp $docpkgs {
#review - versions?
#we should be able to load more specific punk::args pkg based on result of [package present $pkg]
catch {
#$COMMANDSTACKNEXT require $pkg {*}$vwant
$COMMANDSTACKNEXT require punk::args::$dp
}
}
#---------------------------------------------------------------
return $require_result
}
default {
return [$COMMANDSTACKNEXT {*}$args]

6
src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm
Unescape View File

@ -325,7 +325,8 @@ namespace eval punk::path {
lappend finalparts ..
}
default {
lpop finalparts
#lpop finalparts
ledit finalparts end end
}
}
}
@ -345,7 +346,8 @@ namespace eval punk::path {
switch -exact -- $p {
. - "" {}
.. {
lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7
#lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7
ledit finalparts end end ;#uses punk::lib::compat::ledit if on < 8.7
}
default {
lappend finalparts $p

10
src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm
Unescape View File

@ -34,6 +34,7 @@ set tcl_interactive 1
#}
#-------------------------------------------------------------------------------------
if {[package provide punk::libunknown] eq ""} {
#maintenance - also in src/vfs/_config/punk_main.tcl
set libunks [list]
foreach tm_path [tcl::tm::list] {
set punkdir [file join $tm_path punk]
@ -58,7 +59,7 @@ if {[package provide punk::libunknown] eq ""} {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init} errM]} {
if {[catch {punk::libunknown::init -caller repl} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}
@ -2784,7 +2785,7 @@ namespace eval repl {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init} errM]} {
if {[catch {punk::libunknown::init -caller "repl init_script"} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}
@ -3071,6 +3072,9 @@ namespace eval repl {
interp create code
code eval [list namespace eval ::punk::libunknown {}]
catch {
#JJJ REVIEW.
#If libunknown was loaded when packages already in the package database
#then the epoch info may be wrong.
code eval [list set ::punk::libunknown::epoch $::punk::libunknown::epoch]
}
}
@ -3454,7 +3458,7 @@ namespace eval repl {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init} errM]} {
if {[catch {punk::libunknown::init -caller "repl init_script punk"} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}

3661
src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm
View File

File diff suppressed because it is too large Load Diff

2
src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm
Unescape View File

@ -116,7 +116,7 @@ tcl::namespace::eval punk::repl::codethread {
#review/test
catch {package require punk::ns}
catch {package rquire punk::repl}
catch {package require punk::repl}
#variable xyz

11
src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm
Unescape View File

@ -420,7 +420,11 @@ tcl::namespace::eval punk::zip {
punk::args::define {
@id -id ::punk::zip::Addentry
@cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan'
@cmd -name punk::zip::Addentry\
-summary\
"Add zip-entry for file at 'path'"\
-help\
"Add a single file at 'path' to open channel 'zipchan'
return a central directory file record"
@opts
-comment -default "" -help "An optional comment specific to the added file"
@ -565,7 +569,10 @@ tcl::namespace::eval punk::zip {
punk::args::define {
@id -id ::punk::zip::mkzip
@cmd -name punk::zip::mkzip\
-help "Create a zip archive in 'filename'"
-summary\
"Create a zip archive in 'filename'."\
-help\
"Create a zip archive in 'filename'"
@opts
-offsettype -default "archive" -choices {archive file}\
-help "zip offsets stored relative to start of entire file or relative to start of zip-archive

3322
src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.tm
View File

File diff suppressed because it is too large Load Diff

107
src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm
Unescape View File

@ -249,7 +249,29 @@ namespace eval shellrun {
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
lappend PUNKARGS [list {
@id -id ::shellrun::runout
@leaders -min 0 -max 0
@opts
-echo -type none
-nonewline -type none
-tcl -type none -default 0
-debug -type none -default 0
--timeout= -type integer
@values -min 1 -max -1
cmdname -type string
cmdarg -type any -multiple 1 -optional 1
}]
proc runout {args} {
set argd [punk::args::parse $args withid ::shellrun::runout]
lassign [dict values $argd] leaders opts values received
if {[dict exists $received "-nonewline"]} {
set nonewline 1
} else {
set nonewline 0
}
#set_last_run_display [list]
variable runout
variable runerr
@ -257,15 +279,10 @@ namespace eval shellrun {
set runerr ""
set RST [a]
set splitargs [get_run_opts $args]
set runopts [dict get $splitargs runopts]
set cmdargs [dict get $splitargs cmdargs]
#set splitargs [get_run_opts $args]
#set runopts [dict get $splitargs runopts]
#set cmdargs [dict get $splitargs cmdargs]
if {"-nonewline" in $runopts} {
set nonewline 1
} else {
set nonewline 0
}
#puts stdout "RUNOUT cmdargs: $cmdargs"
@ -275,7 +292,7 @@ namespace eval shellrun {
#set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}]
#
#when not echoing - use float-locked so that the repl's stack is bypassed
if {"-echo" in $runopts} {
if {[dict exists $received "-echo"]} {
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}]
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}]
#set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}]
@ -284,10 +301,23 @@ namespace eval shellrun {
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}]
}
set callopts ""
if {"-tcl" in $runopts} {
append callopts " -tclscript 1"
set callopts [dict create]
if {[dict exists $received "-tcl"]} {
dict set callopts -tclscript 1
}
if {[dict exists $received "-debug"]} {
dict set callopts -debug 1
}
if {[dict exists $received --timeout]} {
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash
}
set cmdname [dict get $values cmdname]
if {[dict exists $received cmdarg]} {
set cmdarglist [dict get $values cmdarg]
} else {
set cmdarglist {}
}
set cmdargs [concat $cmdname $cmdarglist]
#shellfilter::run [lrange $args 1 end] -teehandle punksh -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ]
@ -301,7 +331,7 @@ namespace eval shellrun {
#shellfilter::stack::remove commandout $outvar_stackid
if {[dict exists $exitinfo error]} {
if {"-tcl" in $runopts} {
if {[dict exists $received "-tcl"]} {
} else {
#we must raise an error.
@ -382,28 +412,61 @@ namespace eval shellrun {
}
}
lappend PUNKARGS [list {
@id -id ::shellrun::runerr
@leaders -min 0 -max 0
@opts
-echo -type none
-nonewline -type none
-tcl -type none -default 0
-debug -type none -default 0
--timeout= -type integer
@values -min 1 -max -1
cmdname -type string
cmdarg -type any -multiple 1 -optional 1
}]
proc runerr {args} {
set argd [punk::args::parse $args withid ::shellrun::runout]
lassign [dict values $argd] leaders opts values received
if {[dict exists $received "-nonewline"]} {
set nonewline 1
} else {
set nonewline 0
}
#set_last_run_display [list]
variable runout
variable runerr
set runout ""
set runerr ""
set splitargs [get_run_opts $args]
set runopts [dict get $splitargs runopts]
set cmdargs [dict get $splitargs cmdargs]
#set splitargs [get_run_opts $args]
#set runopts [dict get $splitargs runopts]
#set cmdargs [dict get $splitargs cmdargs]
if {"-nonewline" in $runopts} {
set nonewline 1
set callopts [dict create]
if {[dict exists $received "-tcl"]} {
dict set callopts -tclscript 1
}
if {[dict exists $received "-debug"]} {
dict set callopts -debug 1
}
if {[dict exists $received --timeout]} {
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash
}
set cmdname [dict get $values cmdname]
if {[dict exists $received cmdarg]} {
set cmdarglist [dict get $values cmdarg]
} else {
set nonewline 0
set cmdarglist {}
}
set cmdargs [concat $cmdname $cmdarglist]
set callopts ""
if {"-tcl" in $runopts} {
if {[dict exists $received "-tcl"]} {
append callopts " -tclscript 1"
}
if {"-echo" in $runopts} {
if {[dict exists $received "-echo"]} {
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}]
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}]
} else {

BIN
src/vfs/_vfscommon.vfs/modules/test/punk/ansi-0.1.1.tm
View File

Binary file not shown.

BIN
src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm
View File

Binary file not shown.

47
src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm
Unescape View File

@ -137,11 +137,31 @@ tcl::namespace::eval textblock {
return " -choices \{$choices\} -help {algorithm choice $choicemsg} "
}
}
namespace eval argdoc {
tcl::namespace::import ::punk::ansi::a+
# -- --- --- --- ---
#non colour SGR codes
# we can use these directly via ${$I} etc without marking a definition with @dynamic
#This is because they don't need to change when colour switched on and off.
set I [a+ italic]
set NI [a+ noitalic]
set B [a+ bold]
set N [a+ normal]
# -- --- --- --- ---
proc example {str} {
set str [string trimleft $str \n]
set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Web-gray bold white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]]
set result [textblock::bookend_lines $block [a] "[a defaultbg] [a]"]
#puts $result
return $result
}
}
# hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\
# "algorithm choice"
namespace eval argdoc {
set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {$[::textblock::argdoc::hash_algorithm_choices_and_help]}
set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {${[::textblock::argdoc::hash_algorithm_choices_and_help]}}
punk::args::define {
@dynamic
@id -id ::textblock::use_hash
@ -7769,11 +7789,24 @@ tcl::namespace::eval textblock {
# ${[textblock::frame_samples]}
#todo punk::args alias for centre center etc?
namespace eval argdoc {
punk::args::define {
@dynamic
@id -id ::textblock::frame
@cmd -name "textblock::frame"\
-help "Frame a block of text with a border."
-summary "Frame a block of content with a border."\
-help\
"This command allows content to be framed with various border styles. The content can include
other ANSI codes and unicode characters. Some predefined border types can be selected with
the -type option and the characters can be overridden either in part or in total by supplying
some or all entries in the -boxmap dictionary.
The ${$B}textblock::framedef${$N} command can be used to return a dictionary for a frame type.
Border elements can also be suppressed on chosen sides with -boxlimits.
ANSI colours can be applied to borders or as defaults for the content using -ansiborder and
-ansibase options.
The punk::ansi::a+ function (aliased as a+) can be used to apply ANSI styles.
e.g
frame -type block -ansiborder [a+ blue Red] -ansibase [a+ black Red] \"A\\nB\""
-checkargs -default 1 -type boolean\
-help "If true do extra argument checks and
provide more comprehensive error info.
@ -7784,7 +7817,11 @@ tcl::namespace::eval textblock {
Set false for performance improvement."
-etabs -default 0\
-help "expanding tabs - experimental/unimplemented."
-type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\
-type -default light\
-type dict\
-typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\
-choices {${[textblock::frametypes]}}\
-choicerestricted 0 -choicecolumns 8\
-choicelabels {
${[textblock::frame_samples]}
}\
@ -7839,6 +7876,7 @@ tcl::namespace::eval textblock {
No trailing ANSI reset required.
${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}"
}
}
#options before content argument - which is allowed to be absent
#frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation.
@ -7886,7 +7924,8 @@ tcl::namespace::eval textblock {
if {[lindex $args end-1] eq "--"} {
set contents [lpop optlist end]
set has_contents 1
lpop optlist end ;#drop the end-of-opts flag
#lpop optlist end
ledit optlist end end;#drop the end-of-opts flag
} else {
set optlist $args
set contents ""

Write Preview
Loading…
Cancel
Save