Browse Source

make.tcl bootsupport fixes etc

master
Julian Noble 2 months ago
parent
commit
d926570b8c
  1. 37
      src/bootsupport/modules/argparsingtest-0.1.0.tm
  2. 349
      src/bootsupport/modules/dictn-0.1.1.tm
  3. 2
      src/bootsupport/modules/include_modules.config
  4. 702
      src/bootsupport/modules/modpod-0.1.2.tm
  5. 4773
      src/bootsupport/modules/overtype-1.6.5.tm
  6. 1485
      src/bootsupport/modules/punk-0.1.tm
  7. 2
      src/bootsupport/modules/punk/aliascore-0.1.0.tm
  8. 1103
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  9. 966
      src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm
  10. 5341
      src/bootsupport/modules/punk/args-0.1.1.tm
  11. 5502
      src/bootsupport/modules/punk/args-0.1.4.tm
  12. 6400
      src/bootsupport/modules/punk/args-0.1.6.tm
  13. 6458
      src/bootsupport/modules/punk/args-0.1.7.tm
  14. 7213
      src/bootsupport/modules/punk/args-0.1.8.tm
  15. 5509
      src/bootsupport/modules/punk/args-0.2.tm
  16. 4
      src/bootsupport/modules/punk/config-0.1.tm
  17. 21
      src/bootsupport/modules/punk/console-0.1.1.tm
  18. 1
      src/bootsupport/modules/punk/du-0.1.0.tm
  19. 285
      src/bootsupport/modules/punk/lib-0.1.2.tm
  20. 922
      src/bootsupport/modules/punk/libunknown-0.1.tm
  21. 22
      src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm
  22. 9
      src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  23. 40
      src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm
  24. 3
      src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  25. 217
      src/bootsupport/modules/punk/ns-0.1.0.tm
  26. 113
      src/bootsupport/modules/punk/packagepreference-0.1.0.tm
  27. 6
      src/bootsupport/modules/punk/path-0.1.0.tm
  28. 3
      src/bootsupport/modules/punk/pipe-1.0.tm
  29. 2
      src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
  30. 11
      src/bootsupport/modules/punk/zip-0.1.1.tm
  31. 8
      src/bootsupport/modules/punkcheck-0.1.0.tm
  32. 3329
      src/bootsupport/modules/shellfilter-0.2.tm
  33. 201
      src/bootsupport/modules/textblock-0.1.3.tm
  34. 4
      src/bootsupport/modules_tcl8/include_modules.config
  35. BIN
      src/bootsupport/modules_tcl8/thread/platform/win32_x86_64_tcl8-2.8.9.tm
  36. 85
      src/make.tcl
  37. 38
      src/modules/punk/libunknown-0.1.tm
  38. 22
      src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm
  39. 40
      src/modules/punk/mix/commandset/project-999999.0a1.0.tm
  40. 2
      src/modules/punk/repl-999999.0a1.0.tm
  41. 8
      src/modules/punkcheck-0.1.0.tm
  42. 85
      src/project_layouts/custom/_project/punk.basic/src/make.tcl
  43. 37
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm
  44. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config
  45. 1485
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm
  46. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm
  47. 1103
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  48. 966
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm
  49. 5868
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm
  50. 4
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm
  51. 21
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
  52. 1
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm
  53. 285
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm
  54. 922
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm
  55. 22
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm
  56. 9
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  57. 40
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm
  58. 3
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  59. 217
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  60. 113
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
  61. 6
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm
  62. 3
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/pipe-1.0.tm
  63. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
  64. 11
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm
  65. 8
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm
  66. 3329
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.tm
  67. 201
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  68. 85
      src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl
  69. 37
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm
  70. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config
  71. 1485
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm
  72. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm
  73. 1103
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  74. 966
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm
  75. 6274
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm
  76. 4
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm
  77. 21
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
  78. 1
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm
  79. 285
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm
  80. 922
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm
  81. 22
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm
  82. 9
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  83. 40
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm
  84. 3
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  85. 217
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  86. 113
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
  87. 6
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm
  88. 3
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/pipe-1.0.tm
  89. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
  90. 11
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm
  91. 8
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm
  92. 3329
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.tm
  93. 201
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  94. 85
      src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl
  95. 21
      src/vfs/_config/punk_main.tcl
  96. 5317
      src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm
  97. 5465
      src/vfs/_vfscommon.vfs/modules/punk/args-0.1.1.tm
  98. 5465
      src/vfs/_vfscommon.vfs/modules/punk/args-0.1.2.tm
  99. 5468
      src/vfs/_vfscommon.vfs/modules/punk/args-0.1.3.tm
  100. 5745
      src/vfs/_vfscommon.vfs/modules/punk/args-0.1.4.tm
  101. Some files were not shown because too many files have changed in this diff Show More

37
src/bootsupport/modules/argparsingtest-0.1.0.tm

@ -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

349
src/bootsupport/modules/dictn-0.1.1.tm

@ -1,349 +0,0 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application dictn 0.1.1
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval dictn {
namespace export {[a-z]*}
namespace ensemble create
}
## ::dictn::append
#This can of course 'ruin' a nested dict if applied to the wrong element
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl:
# %set list {a b {c d}}
# %append list x
# a b {c d}x
# IOW - don't do that unless you really know that's what you want.
#
proc ::dictn::append {dictvar path {value {}}} {
if {[llength $path] == 1} {
uplevel 1 [list dict append $dictvar $path $value]
} else {
upvar 1 $dictvar dvar
::set str [dict get $dvar {*}$path]
append str $val
dict set dvar {*}$path $str
}
}
proc ::dictn::create {args} {
::set data {}
foreach {path val} $args {
dict set data {*}$path $val
}
return $data
}
proc ::dictn::exists {dictval path} {
return [dict exists $dictval {*}$path]
}
proc ::dictn::filter {dictval path filterType args} {
::set sub [dict get $dictval {*}$path]
dict filter $sub $filterType {*}$args
}
proc ::dictn::for {keyvalvars dictval path body} {
::set sub [dict get $dictval {*}$path]
dict for $keyvalvars $sub $body
}
proc ::dictn::get {dictval {path {}}} {
return [dict get $dictval {*}$path]
}
proc ::dictn::getdef {dictval path default} {
return [dict getdef $dictval {*}$path $default]
}
proc ::dictn::getwithdefault {dictval path default} {
return [dict getdef $dictval {*}$path $default]
}
if {[info commands ::tcl::dict::getdef] ne ""} {
proc ::dictn::incr {dictvar path {increment {}} } {
if {$increment eq ""} {
::set increment 1
}
if {[llength $path] == 1} {
uplevel 1 [list dict incr $dictvar $path $increment]
} else {
upvar 1 $dictvar dvar
if {![::info exists dvar]} {
dict set dvar {*}$path $increment
} else {
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}]
dict set dvar {*}$path $newval
}
return $dvar
}
}
} else {
proc ::dictn::incr {dictvar path {increment {}} } {
if {$increment eq ""} {
::set increment 1
}
if {[llength $path] == 1} {
uplevel 1 [list dict incr $dictvar $path $increment]
} else {
upvar 1 $dictvar dvar
if {![::info exists dvar]} {
dict set dvar {*}$path $increment
} else {
if {![dict exists $dvar {*}$path]} {
::set val 0
} else {
::set val [dict get $dvar {*}$path]
}
::set newval [expr {$val + $increment}]
dict set dvar {*}$path $newval
}
return $dvar
}
}
}
proc ::dictn::info {dictval {path {}}} {
if {![string length $path]} {
return [dict info $dictval]
} else {
::set sub [dict get $dictval {*}$path]
return [dict info $sub]
}
}
proc ::dictn::keys {dictval {path {}} {glob {}}} {
::set sub [dict get $dictval {*}$path]
if {[string length $glob]} {
return [dict keys $sub $glob]
} else {
return [dict keys $sub]
}
}
proc ::dictn::lappend {dictvar path args} {
if {[llength $path] == 1} {
uplevel 1 [list dict lappend $dictvar $path {*}$args]
} else {
upvar 1 $dictvar dvar
::set list [dict get $dvar {*}$path]
::lappend list {*}$args
dict set dvar {*}$path $list
}
}
proc ::dictn::merge {args} {
error "nested merge not yet supported"
}
#dictn remove dictionaryValue ?path ...?
proc ::dictn::remove {dictval args} {
::set basic [list] ;#buffer basic (1element path) removals to do in a single call.
foreach path $args {
if {[llength $path] == 1} {
::lappend basic $path
} else {
#extract,modify,replace
::set subpath [lrange $path 0 end-1]
::set sub [dict get $dictval {*}$subpath]
::set sub [dict remove $sub [lindex $path end]]
dict set dictval {*}$subpath $sub
}
}
if {[llength $basic]} {
return [dict remove $dictval {*}$basic]
} else {
return $dictval
}
}
proc ::dictn::replace {dictval args} {
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call.
foreach {path val} $args {
if {[llength $path] == 1} {
::lappend basic $path $val
} else {
#extract,modify,replace
::set subpath [lrange $path 0 end-1]
::set sub [dict get $dictval {*}$subpath]
::set sub [dict replace $sub [lindex $path end] $val]
dict set dictval {*}$subpath $sub
}
}
if {[llength $basic]} {
return [dict replace $dictval {*}$basic]
} else {
return $dictval
}
}
proc ::dictn::set {dictvar path newval} {
upvar 1 $dictvar dvar
return [dict set dvar {*}$path $newval]
}
proc ::dictn::size {dictval {path {}}} {
return [dict size [dict get $dictval {*}$path]]
}
proc ::dictn::unset {dictvar path} {
upvar 1 $dictvar dvar
return [dict unset dvar {*}$path
}
proc ::dictn::update {dictvar args} {
::set body [lindex $args end]
::set maplist [lrange $args 0 end-1]
upvar 1 $dictvar dvar
foreach {path var} $maplist {
if {[dict exists $dvar {*}$path]} {
uplevel 1 [list set $var [dict get $dvar $path]]
}
}
catch {uplevel 1 $body} result
foreach {path var} $maplist {
if {[dict exists $dvar {*}$path]} {
upvar 1 $var $var
if {![::info exists $var]} {
uplevel 1 [list dict unset $dictvar {*}$path]
} else {
uplevel 1 [list dict set $dictvar {*}$path [::set $var]]
}
}
}
return $result
}
#an experiment.
proc ::dictn::Applyupdate {dictvar args} {
::set body [lindex $args end]
::set maplist [lrange $args 0 end-1]
upvar 1 $dictvar dvar
::set headscript ""
::set i 0
foreach {path var} $maplist {
if {[dict exists $dvar {*}$path]} {
#uplevel 1 [list set $var [dict get $dvar $path]]
::lappend arglist $var
::lappend vallist [dict get $dvar {*}$path]
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ]
::append headscript \n
::incr i
}
}
::set body $headscript\r\n$body
puts stderr "BODY: $body"
#set result [apply [list args $body] {*}$vallist]
catch {apply [list args $body] {*}$vallist} result
foreach {path var} $maplist {
if {[dict exists $dvar {*}$path] && [::info exists $var]} {
dict set dvar {*}$path [::set $var]
}
}
return $result
}
proc ::dictn::values {dictval {path {}} {glob {}}} {
::set sub [dict get $dictval {*}$path]
if {[string length $glob]} {
return [dict values $sub $glob]
} else {
return [dict values $sub]
}
}
# Standard form:
#'dictn with dictVariable path body'
#
# Extended form:
#'dictn with dictVariable path arrayVariable body'
#
proc ::dictn::with {dictvar path args} {
if {[llength $args] == 1} {
::set body [lindex $args 0]
return [uplevel 1 [list dict with $dictvar {*}$path $body]]
} else {
upvar 1 $dictvar dvar
::lassign $args arrayname body
upvar 1 $arrayname arr
array set arr [dict get $dvar {*}$path]
::set prevkeys [array names arr]
catch {uplevel 1 $body} result
foreach k $prevkeys {
if {![::info exists arr($k)]} {
dict unset $dvar {*}$path $k
}
}
foreach k [array names arr] {
dict set $dvar {*}$path $k $arr($k)
}
return $result
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide dictn [namespace eval dictn {
variable version
::set version 0.1.1
}]
return

2
src/bootsupport/modules/include_modules.config

@ -46,6 +46,7 @@ set bootsupport_modules [list\
modules punkcheck\
modules punkcheck::cli\
modules punk::aliascore\
modules punk::ansi::colourmap\
modules punk::ansi\
modules punk::assertion\
modules punk::args\
@ -61,6 +62,7 @@ set bootsupport_modules [list\
modules punk::fileline\
modules punk::docgen\
modules punk::lib\
modules punk::libunknown\
modules punk::mix\
modules punk::mix::base\
modules punk::mix::cli\

702
src/bootsupport/modules/modpod-0.1.2.tm

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

4773
src/bootsupport/modules/overtype-1.6.5.tm

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

@ -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

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

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,966 @@
# -*- 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}]
#*** !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]

5341
src/bootsupport/modules/punk/args-0.1.1.tm

File diff suppressed because it is too large Load Diff

5502
src/bootsupport/modules/punk/args-0.1.4.tm

File diff suppressed because it is too large Load Diff

6400
src/bootsupport/modules/punk/args-0.1.6.tm

File diff suppressed because it is too large Load Diff

6458
src/bootsupport/modules/punk/args-0.1.7.tm

File diff suppressed because it is too large Load Diff

7213
src/bootsupport/modules/punk/args-0.1.8.tm

File diff suppressed because it is too large Load Diff

5509
src/vfs/_vfscommon.vfs/modules/punk/args-0.1.9.tm → src/bootsupport/modules/punk/args-0.2.tm

File diff suppressed because it is too large Load Diff

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

@ -449,7 +449,7 @@ tcl::namespace::eval punk::config {
Accepts globs eg XDG*"
@leaders -min 1 -max 1
#todo - load more whichconfig choices?
whichconfig -type string -choices {config startup-configuration running-configuration}
whichconfig -type any -choices {config startup-configuration running-configuration}
@values -min 0 -max -1
globkey -type string -default * -optional 1 -multiple 1
}]
@ -495,7 +495,7 @@ tcl::namespace::eval punk::config {
@cmd -name punk::config::configure -help\
"Get/set configuration values from a config"
@leaders -min 1 -max 1
whichconfig -type string -choices {defaults startup-configuration running-configuration}
whichconfig -type any -choices {defaults startup-configuration running-configuration}
@values -min 0 -max 2
key -type string -optional 1
newvalue -optional 1

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

@ -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/bootsupport/modules/punk/du-0.1.0.tm

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

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

@ -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 [llength $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 [llength $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
@ -695,14 +741,15 @@ namespace eval punk::lib {
proc lswap {lvar a z} {
upvar $lvar l
if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} {
set len [llength $l]
if {[lindex_resolve_basic $len $a] < 0 || [lindex_resolve_basic $len $z] < 0} {
#lindex_resolve_basic returns only -1 if out of range
#if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred
#(e.g using: lswap mylist end-2 end on a two element list)
#on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report
#use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned)
set a_index [lindex_resolve $l $a]
set a_index [lindex_resolve $len $a]
set a_msg ""
switch -- $a_index {
-2 {
@ -712,7 +759,7 @@ namespace eval punk::lib {
set a_msg "1st supplied index $a is below the lower bound for the list (0)"
}
}
set z_index [lindex_resolve $l $z]
set z_index [lindex_resolve $len $z]
set z_msg ""
switch -- $z_index {
-2 {
@ -1100,7 +1147,7 @@ namespace eval punk::lib {
- then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator.
e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1
Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent
The second level segement in each pattern switches to a dict operation to retrieve the value by key.
The second level segment in each pattern switches to a dict operation to retrieve the value by key.
When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level.
}
}]
@ -1137,11 +1184,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 +1222,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"
@ -1465,7 +1515,7 @@ namespace eval punk::lib {
if {![regexp $re_idxdashidx $p _match a b]} {
error "unrecognised pattern $p"
}
set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high
set lower_resolve [punk::lib::lindex_resolve [llength $dval] $a] ;#-2 for too low, -1 for too high
#keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds
if {${lower_resolve} == -2} {
##x
@ -1478,7 +1528,7 @@ namespace eval punk::lib {
} else {
set lower $lower_resolve
}
set upper [punk::lib::lindex_resolve $dval $b]
set upper [punk::lib::lindex_resolve [llength $dval] $b]
if {$upper == -3} {
##x
#upper bound is below list range -
@ -1831,7 +1881,8 @@ namespace eval punk::lib {
if {$last_hidekey} {
append result \n
}
append result [textblock::join_basic -- $kblock $sblock $vblock] \n
#append result [textblock::join_basic -- $kblock $sblock $vblock] \n
append result [textblock::join_basic_raw $kblock $sblock $vblock] \n
}
set last_hidekey $hidekey
incr kidx
@ -1880,6 +1931,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 +1952,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 +1975,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 +1992,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]
@ -2158,35 +2242,75 @@ namespace eval punk::lib {
}
}
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side
proc lindex_resolve {list index} {
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bounds on upper vs lower side
#REVIEW: This shouldn't really need the list itself - just the length would suffice
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 or string length."\
-help\
"Resolve an index which may be of the forms accepted by Tcl list or string commands such as end-2 or 2+2
to the actual integer index for the supplied list/string length, or to a negative value below -1 indicating
whether the index was below or above the range of possible indices for the length supplied.
Users may define procs which accept a list/string 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/string.
Otherwise it will return an integer corresponding to the position in the data.
This is in stark contrast to Tcl list/string 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/string (datalength 0), 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
datalength -type integer
index -type indexexpression
}
proc lindex_resolve {len index} {
#*** !doctools
#[call [fun lindex_resolve] [arg list] [arg index]]
#[para]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
#[para]Users may define procs which accept a list index and wish to accept the forms understood by Tcl.
#[call [fun lindex_resolve] [arg len] [arg index]]
#[para]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/string length
#[para]Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl.
#[para]This means the proc may be called with something like $x+2 end-$y etc
#[para]Sometimes the actual integer index is desired.
#[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks.
#[para]lindex_resolve will parse the index expression and return:
#[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0)
#[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] 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/string
#[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 ???
#}
if {![string is integer -strict $len]} {
#<0 ?
error "lindex_resolve len must be an integer"
}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
if {$index < 0} {
return -3
} elseif {$index >= [llength $list]} {
} elseif {$index >= $len} {
return -2
} else {
#integer may still have + sign - normalize with expr
@ -2203,7 +2327,7 @@ namespace eval punk::lib {
}
} else {
#index is 'end'
set index [expr {[llength $list]-1}]
set index [expr {$len-1}]
if {$index < 0} {
#special case - 'end' with empty list - treat end like a positive number out of bounds
return -2
@ -2212,7 +2336,7 @@ namespace eval punk::lib {
}
}
if {$offset == 0} {
set index [expr {[llength $list]-1}]
set index [expr {$len-1}]
if {$index < 0} {
return -2 ;#special case as above
} else {
@ -2220,7 +2344,7 @@ namespace eval punk::lib {
}
} else {
#by now, if op = + then offset = 0 so we only need to handle the minus case
set index [expr {([llength $list]-1) - $offset}]
set index [expr {($len-1) - $offset}]
}
if {$index < 0} {
return -3
@ -2245,33 +2369,32 @@ namespace eval punk::lib {
}
if {$index < 0} {
return -3
} elseif {$index >= [llength $list]} {
} elseif {$index >= $len} {
return -2
}
return $index
}
}
}
proc lindex_resolve_basic {list index} {
proc lindex_resolve_basic {len index} {
#*** !doctools
#[call [fun lindex_resolve_basic] [arg list] [arg index]]
#[call [fun lindex_resolve_basic] [arg len] [arg index]]
#[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2)
#[para] returns -1 for out of range at either end, or a valid integer index
#[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound
#[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command
#[para] This is only likely to be faster than average over lindex_resolve for small lists and for Tcl which has the builtin lseq command
#[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1
#[para] For pure integer indices the performance should be equivalent
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+
# - which
#for {set i 0} {$i < [llength $list]} {incr i} {
# lappend indices $i
#}
if {![string is integer -strict $len]} {
error "lindex_resolve_basic len must be an integer"
}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
#avoid even the lseq overhead when the index is simple
if {$index < 0 || ($index >= [llength $list])} {
if {$index < 0 || ($index >= $len)} {
#even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method.
return -1
} else {
@ -2279,13 +2402,15 @@ namespace eval punk::lib {
return [expr {$index}]
}
}
if {[llength $list]} {
set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback.
#if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?)
if {$len > 0} {
#For large len - this is a wasteful allocation if no true lseq available in Tcl version.
#lseq produces an 'arithseries' object which we can index into without allocating an entire list (REVIEW)
set testlist [punk::lib::range 0 [expr {$len-1}]] ;# uses lseq if available, has fallback.
} else {
set indices [list]
set testlist [list]
#we want to call 'lindex' even in this case - to get the appropriate error message
}
set idx [lindex $indices $index]
set idx [lindex $testlist $index]
if {$idx eq ""} {
#we have no way to determine if out of bounds is at lower vs upper end
return -1
@ -2304,6 +2429,81 @@ namespace eval punk::lib {
}
}
proc string_splitbefore {str index} {
if {![string is integer -strict $index]} {
set index [punk::lib::lindex_resolve [string length $str] $index]
switch -- $index {
-2 {
return [list $str ""]
}
-3 {
return [list "" $str]
}
}
}
return [list [string range $str 0 $index-1] [string range $str $index end]]
#scan %s stops at whitespace - not useful here.
#scan $s %${p}s%s
}
proc string_splitbefore_indices {str args} {
set parts [list $str]
set sizes [list [string length $str]]
set s 0
foreach index $args {
if {![string is integer -strict $index]} {
set index [punk::lib::lindex_resolve [string length $str] $index]
switch -- $index {
-2 {
if {[lindex $sizes end] != 0} {
ledit parts end end [lindex $parts end] {}
ledit sizes end end [lindex $sizes end] 0
}
continue
}
-3 {
if {[lindex $sizes 0] != 0} {
ledit parts 0 0 {} [lindex $parts 0]
ledit sizes 0 0 0 [lindex $sizes 0]
}
continue
}
}
}
if {$index <= 0} {
if {[lindex $sizes 0] != 0} {
ledit parts 0 0 {} [lindex $parts 0]
ledit sizes 0 0 0 [lindex $sizes 0]
}
continue
}
if {$index >= [string length $str]} {
if {[lindex $sizes end] != 0} {
ledit parts end end [lindex $parts end] {}
ledit sizes end end [lindex $sizes end] 0
}
continue
}
set i -1
set a 0
foreach sz $sizes {
incr i
if {$a + $sz > $index} {
set p [lindex $parts $i]
#puts "a:$a index:$index"
if {$a == $index} {
break
}
ledit parts $i $i [string range $p 0 [expr {$index -$a -1}]] [string range $p $index-$a end]
ledit sizes $i $i [expr {$index - $a}] [expr {($a + $sz)-$index}]
break
}
incr a $sz
}
#puts "->parts:$parts"
#puts "->sizes:$sizes"
}
return $parts
}
proc K {x y} {return $x}
#*** !doctools
@ -3133,8 +3333,7 @@ namespace eval punk::lib {
#Each resulting line should have a reset of some type at start and a pure-reset at end to stop
#see if we can find an ST sequence that most terminals will not display for marking sections?
if {$opt_ansireplays} {
#package require punk::ansi
<require_punk_ansi>
<require_punk_ansi> ;#package require punk::ansi
if {$opt_ansiresets} {
set RST "\x1b\[0m"
} else {

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

File diff suppressed because it is too large Load Diff

22
src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm

@ -53,11 +53,6 @@ namespace eval punk::mix::commandset::loadedlib {
#REVIEW - this doesn't result in full scans
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything
if {[catch {package require natsort}]} {
set has_natsort 0
} else {
set has_natsort 1
}
set packages [package names]
set matches [list]
foreach search $searchstrings {
@ -85,11 +80,7 @@ namespace eval punk::mix::commandset::loadedlib {
# set versions $v
#}
}
if {$has_natsort} {
set versions [natsort::sort $versions]
} else {
set versions [lsort $versions]
}
set versions [lsort -command {package vcompare} $versions]
if {$opt_highlight} {
set v [package provide $m]
if {$v ne ""} {
@ -188,11 +179,6 @@ namespace eval punk::mix::commandset::loadedlib {
}
proc info {libname} {
if {[catch {package require natsort}]} {
set has_natsort 0
} else {
set has_natsort 1
}
catch {package require $libname 1-0} ;#ensure pkg system has loaded/searched - using unsatisfiable version range
set pkgsknown [package names]
if {[set posn [lsearch $pkgsknown $libname]] >= 0} {
@ -201,11 +187,7 @@ namespace eval punk::mix::commandset::loadedlib {
puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path"
}
set versions [package versions [lindex $libname 0]]
if {$has_natsort} {
set versions [natsort::sort $versions]
} else {
set versions [lsort $versions]
}
set versions [lsort -command {package vcompare} $versions]
if {![llength $versions]} {
puts stderr "No version numbers found for library/module $libname"
return false

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

@ -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]

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

@ -592,10 +592,23 @@ namespace eval punk::mix::commandset::project {
namespace export *
namespace path [namespace parent]
punk::args::define {
@id -id ::punk::mix::commandset::project::collection::_default
@cmd -name "punk::mix::commandset::project::collection::_default"\
-summary\
"List projects under fossil managment."\
-help\
"List projects under fossil management, showing fossil db location and number of checkouts"
@values -min 0 -max -1
glob -type string -multiple 1 -default *
}
#e.g imported as 'projects'
proc _default {{glob {}} args} {
proc _default {args} {
set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default]
set globlist [dict get $argd values glob]
#*** !doctools
#[call [fun _default] [arg glob] [opt {option value...}]]
#[call [fun _default] [arg glob...]]
#[para]List projects under fossil management, showing fossil db location and number of checkouts
#[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied
#[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s
@ -604,7 +617,7 @@ namespace eval punk::mix::commandset::project {
#[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection
#[para]Will result in the command being available as <ensemblecommand> projects
package require overtype
set db_projects [lib::get_projects $glob]
set db_projects [lib::get_projects {*}$globlist]
set col1items [lsearch -all -inline -index 0 -subindices $db_projects *]
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *]
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *]
@ -1012,12 +1025,21 @@ namespace eval punk::mix::commandset::project {
#consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run
return [string cat % $tagname %]
}
#get project info only by opening the central confg-db
#(will not have proper project-name etc)
proc get_projects {{globlist {}} args} {
if {![llength $globlist]} {
set globlist [list *]
}
punk::args::define {
@id -id ::punk::mix::commandset::project::lib::get_projects
@cmd -name punk::mix::commandset::project::lib::get_projects\
-summary\
"List projects referred to by central fossil config-db."\
-help\
"Get project info only by opening the central fossil config-db
(will not have proper project-name etc)"
@values -min 0 -max -1
glob -type string -multiple 1 -default * -optional 1
}
proc get_projects {args} {
set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects]
set globlist [dict get $argd values glob]
set fossil_prog [auto_execok fossil]
set configdb [punk::repo::fossil_get_configdb]

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

@ -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]

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

@ -177,10 +177,10 @@ tcl::namespace::eval punk::ns {
} else {
set fq_nspath $nspath
}
if {[catch {nseval_ifexists $fq_nspath {}}]} {
return 0
} else {
if {[nseval_ifexists $fq_nspath {::string cat ok}] eq "ok"} {
return 1
} else {
return 0
}
}
@ -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]
@ -757,13 +758,20 @@ tcl::namespace::eval punk::ns {
}
set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370]
if {[llength $ansinames]} {
return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type][punk::ansi::a]"
return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type]\x1b\[0m"
} else {
return [dict get $marks $type]
}
}
#REVIEW - ansi codes can be *very* confusing to the user when trying to handle lists etc..
punk::args::define {
@id -id ::punk::ns::get_nslist
@cmd -name punk::ns::get_nslist
@opts
-match -default ""
-nsdict -type dict -default {}
}
proc get_nslist {args} {
set known_types [list children commands exported imported aliases procs ensembles ooclasses ooobjects ooprivateobjects ooprivateclasses native coroutines interps zlibstreams]
set defaults [dict create\
@ -774,6 +782,9 @@ tcl::namespace::eval punk::ns {
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- ---
set fq_glob [dict get $opts -match]
if {$fq_glob eq ""} {
set fq_glob [uplevel 1 nsthis]::*
}
set requested_types [dict get $opts -types]
set opt_nsdict [dict get $opts -nsdict]
@ -834,7 +845,7 @@ tcl::namespace::eval punk::ns {
set zlibstreams [list]
set usageinfo [list]
if {$opt_nsdict eq ""} {
if {![dict size $opt_nsdict]} {
set nsmatches [get_ns_dicts $fq_glob -allbelow 0]
set itemcount 0
set matches_with_results [list]
@ -866,6 +877,8 @@ tcl::namespace::eval punk::ns {
}
if {"commands" in $types} {
set commands [dict get $contents commands]
}
set usageinfo [dict get $contents usageinfo]
foreach t $types {
switch -- $t {
exported {
@ -909,8 +922,6 @@ tcl::namespace::eval punk::ns {
}
}
}
set usageinfo [dict get $contents usageinfo]
}
set numchildren [llength $children]
if {$numchildren} {
@ -1067,7 +1078,7 @@ tcl::namespace::eval punk::ns {
} else {
}
if {$cmd in $imported} {
set prefix [overtype::right $prefix "-[a+ yellow bold]I[a+]"]
set prefix [overtype::right $prefix "-[a+ yellow bold]I[a]"]
}
}
if {$cmd in $usageinfo} {
@ -1075,7 +1086,8 @@ tcl::namespace::eval punk::ns {
} else {
set u ""
}
set cmd$i "${prefix} $c$cmd_display$u"
#set cmd$i "${prefix} $c$cmd_display$u"
set cmd$i "${prefix} [punk::ansi::ansiwrap -rawansi $c $cmd_display]$u"
#set c$i $c
set c$i ""
lappend seencmds $cmd
@ -1146,7 +1158,11 @@ tcl::namespace::eval punk::ns {
the child namespaces and commands within
the namespace(s) matched by glob."
@opts
-nspathcommands -type boolean -default 0
-nspathcommands -type boolean -default 0 -help\
"When a namespace has entries configured in 'namespace path', the default result for nslist
will display just a basic note: 'Also resolving cmds in namespace paths: <namespaces>'.
If -nspathcommands is true, it will also display subtables showing the commands resolvable
via any such listed namespaces."
-types
@values -min 0 -max -1
glob -multiple 1 -optional 1 -default "*"
@ -1205,9 +1221,9 @@ tcl::namespace::eval punk::ns {
if {[dict size [dict get $nsdict namespacepath]]} {
set path_text ""
if {!$opt_nspathcommands} {
append path_text \n " also resolving cmds in namespace paths: [dict keys [dict get $nsdict namespacepath]]"
append path_text \n " Also resolving cmds in namespace paths: [dict keys [dict get $nsdict namespacepath]]"
} else {
append path_text \n " also resolving cmds in namespace paths:"
append path_text \n " Also resolving cmds in namespace paths:"
set nspathdict [dict get $nsdict namespacepath]
if {!$has_textblock} {
dict for {k v} $nspathdict {
@ -1216,8 +1232,14 @@ tcl::namespace::eval punk::ns {
append path_text \n " cmds: $cmds"
}
} else {
#todo - change to display in column order to be same as main command listing
dict for {k v} $nspathdict {
set t [textblock::list_as_table -title $k -columns 6 [lsort [dict get $v commands]]]
set pathcommands [dict get $v commands]
set columns 6
if {[llength $pathcommands] < 6} {
set columns [llength $v]
}
set t [textblock::list_as_table -title $k -columns $columns [lsort $pathcommands]]
append path_text \n $t
}
}
@ -1423,7 +1445,7 @@ tcl::namespace::eval punk::ns {
}
}
return $matches
}]
}]]
} else {
lappend matched {*}[tcl::namespace::eval $location [list ::info commands [nsjoin ${location} $p]]]
@ -2397,14 +2419,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 +2444,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 +2535,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 +2552,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 +2618,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 +2649,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 +2679,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 +2706,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 +2971,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 +3087,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 +3141,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 +3197,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 +3677,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
}
@ -3620,6 +3703,21 @@ tcl::namespace::eval punk::ns {
comment inserted to display information such as the
namespace origin. Such a comment begins with #corp#."
@opts
-syntax -default basic -choices {none basic}\
-choicelabels {
none\
" Plain text output"
basic\
" Comment and bracket highlights.
This is a basic colourizer - not
a full Tcl syntax highlighter."
}\
-help\
"Type of syntax highlighting on result.
Note that -syntax none will always return a proper Tcl
List: proc <name> <arglist> <body>
- but a syntax highlighter may return a string that
is not a Tcl list."
@values -min 1 -max -1
commandname -help\
"May be either the fully qualified path for the command,
@ -3629,6 +3727,7 @@ tcl::namespace::eval punk::ns {
proc corp {args} {
set argd [punk::args::parse $args withid ::punk::ns::corp]
set path [dict get $argd values commandname]
set syntax [dict get $argd opts -syntax]
#thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp
#Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name)
if {[info exists punk::console::tabwidth]} {
@ -3713,6 +3812,18 @@ tcl::namespace::eval punk::ns {
lappend argl $a
}
#list proc [nsjoin ${targetns} $name] $argl $body
switch -- $syntax {
basic {
#rudimentary colourising only
set argl [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl]
set body [punk::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one.
set body [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $body]
set body [punk::grepstr -return all -highlight tk-orange {\[|\]} $body]
#ansi colourised items in list format may not always have desired string representation (list escaping can occur)
#return as a string - which may not be a proper Tcl list!
return "proc $resolved {$argl} {\n$body\n}"
}
}
list proc $resolved $argl $body
}
@ -3799,13 +3910,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 +4034,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 +4074,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}

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

@ -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 {} {
@ -194,7 +194,7 @@ tcl::namespace::eval punk::packagepreference {
if {!$is_exact && [llength $vwant] <= 1 } {
#required version unspecified - or specified singularly
set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg]
if {[llength $available_versions] > 1} {
if {[llength $available_versions] >= 1} {
# ---------------------------------------------------------------
#An attempt to detect dll/so loaded and try to load same version
#dll/so files are often named with version numbers that don't contain dots or a version number at all
@ -202,9 +202,11 @@ tcl::namespace::eval punk::packagepreference {
set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg]
if {[llength $pkgloadedinfo]} {
puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available"
lassign $pkgloadedinfo path name
set lcpath [string tolower $path]
if {[llength $available_versions] > 1} {
puts stderr "--> pkg $pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and [llength $available_versions] versions available"
}
lassign $pkgloadedinfo loaded_path name
set lc_loadedpath [string tolower $loaded_path]
#first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement.
set lcpath_to_version [dict create]
foreach av $available_versions {
@ -212,17 +214,19 @@ tcl::namespace::eval punk::packagepreference {
#ifneeded script not always a valid tcl list
if {![catch {llength $scr} scrlen]} {
if {$scrlen == 3 && [lindex $scr 0] eq "load" && [string match -nocase [lindex $scr 2] $pkg]} {
#a basic 'load <path> <pkg>' statement
dict set lcpath_to_version [string tolower [lindex $scr 1]] $av
}
}
}
if {[dict exists $lcpath_to_version $lcpath]} {
set lversion [dict get $lcpath_to_version $lcpath]
if {[dict exists $lcpath_to_version $lc_loadedpath]} {
set lversion [dict get $lcpath_to_version $lc_loadedpath]
} else {
#fallback to a best effort guess based on the path
set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg]
set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $loaded_path $pkg]
}
#puts "====lcpath_to_version: $lcpath_to_version"
if {$lversion ne ""} {
#name matches pkg
#hack for known dll version mismatch
@ -232,24 +236,103 @@ tcl::namespace::eval punk::packagepreference {
if {[llength $vwant] == 1} {
#todo - still check vsatisfies - report a conflict? review
}
return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
#return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
try {
set result [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
} trap {} {emsg eopts} {
#REVIEW - this occurred in punkmagic (rebuild of tclmagic) - probably due to multiple versions of registry
#under different auto_path folders - and mal-ordering in punk::libunknown's tclPkgUnknown
#May be obsolete.. issue still not clear
#A hack for 'couldn't open "<path.dll>": permission denied'
#This happens for example with the tcl9registry13.dll when loading from zipfs - but not in all systems, and not for all dlls.
#exact cause unknown.
#e.g
#%package ifneeded registry 1.3.7
#- load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry
#%load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry
#couldn't open "C:/Users/sleek/AppData/Local/Temp/TCL00003cf8/tcl9registry13.dll": permission denied
#a subsequent load of the path used in the error message works.
#if {[string match "couldn't open \"*\": permission denied" $emsg]} {}
if {[regexp {couldn't open "(.*)":.*permission denied.*} $emsg _ newpath]} {
#Since this is a hack that shouldn't be required - be noisy about it.
puts stderr ">>> $emsg"
puts stderr "punk::packagepreference::require hack: Re-trying load of $pkg with path: $newpath"
return [load $newpath $pkg]
} else {
#puts stderr "??? $emsg"
#dunno - re-raise
return -options $eopts $emsg
}
}
return $result
}
#else puts stderr "> no version determined for pkg: $pkg loaded_path: $loaded_path"
}
}
}
# ---------------------------------------------------------------
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
#j2
$COMMANDSTACKNEXT require punk::args::$dp
}
}
#---------------------------------------------------------------
return $require_result
}
default {
return [$COMMANDSTACKNEXT {*}$args]

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

@ -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

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

@ -373,6 +373,7 @@ tcl::namespace::eval punk::pipe::lib {
if {$end_var_posn > 0} {
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead.
#lassign [scan $token %${end_var_posn}s%s] var spec
#lassign [punk::lib::string_splitbefore $token $end_var_posn] var spec
set var [string range $token 0 $end_var_posn-1]
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec
} else {
@ -430,7 +431,7 @@ tcl::namespace::eval punk::pipe::lib {
}
#if {[string length $token]} {
# #lappend varlist [splitstrposn $token $end_var_posn]
# #lappend varlist [punk::lib::string_splitbefore $token $end_var_posn]
# set var $token
# set spec ""
# if {$end_var_posn > 0} {

2
src/bootsupport/modules/punk/repl/codethread-0.1.1.tm

@ -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/bootsupport/modules/punk/zip-0.1.1.tm

@ -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

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

@ -243,14 +243,10 @@ namespace eval punkcheck {
}
method get_targets_exist {} {
set punkcheck_folder [file dirname [$o_installer get_checkfile]]
#puts stdout "### punkcheck glob -dir $punkcheck_folder -tails {*}$o_targets"
#targets can be paths such as punk/mix/commandset/module-0.1.0.tm - glob can search levels below supplied -dir
set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets]
#set existing [list]
#foreach t $o_targets {
# if {[file exists [file join $punkcheck_folder $t]]} {
# lappend existing $t
# }
#}
return $existing
}
method end {} {

3329
src/bootsupport/modules/shellfilter-0.2.tm

File diff suppressed because it is too large Load Diff

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

@ -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
@ -154,7 +174,6 @@ tcl::namespace::eval textblock {
}
}
proc use_hash {args} {
#set argd [punk::args::get_by_id ::textblock::use_hash $args]
set argd [punk::args::parse $args withid ::textblock::use_hash]
variable use_hash
if {![dict exists $argd received hash_algorithm]} {
@ -2294,7 +2313,8 @@ tcl::namespace::eval textblock {
#JMN
#spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic
set spanned_frame [textblock::join_basic -- {*}$spanned_parts]
#set spanned_frame [textblock::join_basic -- {*}$spanned_parts]
set spanned_frame [textblock::join_basic_raw {*}$spanned_parts]
if {$spans_to_rhs} {
if {$cidx == 0} {
@ -2363,7 +2383,8 @@ tcl::namespace::eval textblock {
} else {
#this_span == 1
set spanned_frame [textblock::join_basic -- $header_cell_startspan]
#set spanned_frame [textblock::join_basic -- $header_cell_startspan]
set spanned_frame [textblock::join_basic_raw $header_cell_startspan]
}
@ -3992,7 +4013,8 @@ tcl::namespace::eval textblock {
set body_build ""
} else {
#body blocks should not be ragged - so can use join_basic
set body_build [textblock::join_basic -- {*}$body_blocks]
#set body_build [textblock::join_basic -- {*}$body_blocks]
set body_build [textblock::join_basic_raw {*}$body_blocks]
}
if {$headerheight > 0} {
set table [tcl::string::cat $header_build \n $body_build]
@ -4149,7 +4171,6 @@ tcl::namespace::eval textblock {
proc periodic {args} {
#For an impressive interactive terminal app (javascript)
# see: https://github.com/spirometaxas/periodic-table-cli
#set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts]
set opts [dict get [punk::args::parse $args withid ::textblock::periodic] opts]
set opt_return [tcl::dict::get $opts -return]
if {[tcl::dict::get $opts -forcecolour]} {
@ -4446,7 +4467,7 @@ tcl::namespace::eval textblock {
proc list_as_table {args} {
set FRAMETYPES [textblock::frametypes]
set argd [punk::args::get_by_id ::textblock::list_as_table $args]
set argd [punk::args::parse $args withid ::textblock::list_as_table]
set opts [dict get $argd opts]
set received [dict get $argd received]
@ -4644,7 +4665,8 @@ tcl::namespace::eval textblock {
if {[tcl::string::last \n $charblock] >= 0} {
if {$blockwidth > 1} {
#set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks )
set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]]
#set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]]
set row [textblock::join_basic_raw {*}[lrepeat $blockwidth $charblock]]
} else {
set row $charblock
}
@ -4694,7 +4716,7 @@ tcl::namespace::eval textblock {
}
proc testblock {args} {
set argd [punk::args::get_by_id ::textblock::testblock $args]
set argd [punk::args::parse $args withid ::textblock::testblock]
set colour [dict get $argd values colour]
set size [dict get $argd opts -size]
@ -4762,7 +4784,8 @@ tcl::namespace::eval textblock {
if {"noreset" in $colour} {
return [textblock::join_basic -ansiresets 0 -- {*}$clist]
} else {
return [textblock::join_basic -- {*}$clist]
#return [textblock::join_basic -- {*}$clist]
return [textblock::join_basic_raw {*}$clist]
}
} elseif {"rainbow" in $colour} {
#direction must be horizontal
@ -5019,19 +5042,20 @@ tcl::namespace::eval textblock {
-width ""\
-overflow 0\
-within_ansi 0\
-return block\
]
#known_samewidth of empty string means we don't know either way, 0 is definitely 'ragged', 1 is definitely homogenous
#review!?
#-within_ansi means after a leading ansi code when doing left pad on all but last line
#-within_ansi means before a trailing ansi code when doing right pad on all but last line
set usage "pad block ?-padchar <sp>|<character>? ?-which right|left|centre? ?-known_hasansi \"\"|<bool>? ?-known_blockwidth \"\"|<int>? ?-width auto|<int>? ?-within_ansi 1|0?"
foreach {k v} $args {
switch -- $k {
-padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi {
-padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi - -return {
tcl::dict::set opts $k $v
}
default {
set usage "pad block ?-padchar <sp>|<character>? ?-which right|left|centre? ?-known_hasansi \"\"|<bool>? ?-known_blockwidth \"\"|<int>? ?-width auto|<int>? ?-within_ansi 1|0? ?-return block|list?"
error "textblock::pad unrecognised option '$k'. Usage: $usage"
}
}
@ -5177,25 +5201,34 @@ tcl::namespace::eval textblock {
set line_len 0
set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad
foreach {pt ansi} $parts {
if {$pt ne ""} {
set has_nl [expr {[tcl::string::last \n $pt]>=0}]
if {$has_nl} {
if {$pt eq ""} {
#we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes
lappend line_chunks ""
} elseif {[tcl::string::last \n $pt]==-1} {
lappend line_chunks $pt
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
incr line_len [punk::char::grapheme_width_cached $pt] ;#memleak - REVIEW
}
} else {
#set has_nl [expr {[tcl::string::last \n $pt]>=0}]
#if {$has_nl} {
set pt [tcl::string::map [list \r\n \n] $pt]
set partlines [split $pt \n]
} else {
set partlines [list $pt]
}
set last [expr {[llength $partlines]-1}]
set p 0
foreach pl $partlines {
lappend line_chunks $pl
#} else {
# set partlines [list $pt]
#}
#set last [expr {[llength $partlines]-1}]
#set p -1
foreach pl [lrange $partlines 0 end-1] {
#incr p
lappend line_chunks $pl ;#we need to lappend because there can already be some pt and ansi entries for the current line from previous {pt ansi} values where pt had no newline.
#incr line_len [punk::char::ansifreestring_width $pl]
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
}
if {$p != $last} {
#if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
# incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
#}
#do padding
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
set missing [expr {$width - $line_len}]
} else {
set missing [expr {$width - $datawidth}]
@ -5258,15 +5291,20 @@ tcl::namespace::eval textblock {
set line_len 0
incr lnum
}
incr p
#deal with last part zzz of xxx\nyyy\nzzz - not yet a complete line
set pl [lindex $partlines end]
lappend line_chunks $pl ;#we need to lappend because there can already be some pt and ansi entries for the current line from previous {pt ansi} values where pt had no newline.
if {$pl ne "" && ($known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq "")} {
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
}
} else {
#we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes
lappend line_chunks ""
}
#don't let trailing empty ansi affect the line_chunks length
if {$ansi ne ""} {
lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content?
lappend line_chunks $ansi ;#don't update line_len
#- review - ansi codes with visible content?
#- There shouldn't be any, even though for example some terminals display PM content
#e.g OSC 8 is ok as it has the uri 'inside' the ansi sequence, but that's ok because the displayable part is outside and is one of our pt values from split_codes.
}
}
#pad last line
@ -5325,7 +5363,11 @@ tcl::namespace::eval textblock {
}
}
lappend lines [::join $line_chunks ""]
if {[tcl::dict::get $opts -return] eq "block"} {
return [::join $lines \n]
} else {
return $lines
}
}
#left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single
@ -5566,7 +5608,7 @@ tcl::namespace::eval textblock {
#join without regard to each line length in a block (no padding added to make each block uniform)
proc ::textblock::join_basic {args} {
set argd [punk::args::get_by_id ::textblock::join_basic $args]
set argd [punk::args::parse $args withid ::textblock::join_basic]
set ansiresets [tcl::dict::get $argd opts -ansiresets]
set blocks [tcl::dict::get $argd values blocks]
@ -5602,6 +5644,33 @@ tcl::namespace::eval textblock {
}
return [::join $outlines \n]
}
proc ::textblock::join_basic_raw {args} {
#no options. -*, -- are legimate blocks
set blocklists [lrepeat [llength $args] ""]
set blocklengths [lrepeat [expr {[llength $args]+1}] 0] ;#add 1 to ensure never empty - used only for rowcount max calc
set i -1
foreach b $args {
incr i
if {[punk::ansi::ta::detect $b]} {
#-ansireplays 1 quite expensive e.g 7ms in 2024
set blines [punk::lib::lines_as_list -ansireplays 1 -ansiresets auto -- $b]
} else {
set blines [split $b \n]
}
lset blocklengths $i [llength $blines]
lset blocklists $i $blines
}
set rowcount [tcl::mathfunc::max {*}$blocklengths]
set outlines [lrepeat $rowcount ""]
for {set r 0} {$r < $rowcount} {incr r} {
set row ""
foreach blines $blocklists {
append row [lindex $blines $r]
}
lset outlines $r $row
}
return [::join $outlines \n]
}
proc ::textblock::join_basic2 {args} {
#@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width.
# Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
@ -5686,9 +5755,12 @@ tcl::namespace::eval textblock {
}
set idx 0
set blocklists [list]
#set blocklists [list]
set blocklists [lrepeat [llength $blocks] ""]
set rowcount 0
set bidx -1
foreach b $blocks {
incr bidx
#we need the width of a rendered block for per-row renderline calls or padding
#we may as well use widthinfo to also determine raggedness state to pass on to pad function
#set bwidth [width $b]
@ -5705,18 +5777,21 @@ tcl::namespace::eval textblock {
if {[punk::ansi::ta::detect $b]} {
# - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?)
set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n]
set bl [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
#set blines [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
set blines [textblock::pad $replay_block -return lines -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "]
} else {
#each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi
set bl [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
#set blines [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
set blines [textblock::pad $b -return lines -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "]
}
set rowcount [expr {max($rowcount,[llength $bl])}]
lappend blocklists $bl
set rowcount [expr {max($rowcount,[llength $blines])}]
#lappend blocklists $bl
lset blocklists $bidx $blines
set width($idx) $bwidth
incr idx
}
set outlines [list]
set outlines [lrepeat $rowcount ""]
for {set r 0} {$r < $rowcount} {incr r} {
set row ""
for {set c 0} {$c < [llength $blocklists]} {incr c} {
@ -5726,7 +5801,8 @@ tcl::namespace::eval textblock {
}
append row $cell
}
lappend outlines $row
#lappend outlines $row
lset outlines $r $row
}
return [::join $outlines \n]
}
@ -5910,7 +5986,7 @@ tcl::namespace::eval textblock {
set table [[textblock::spantest] print]
set punks [a+ web-lawngreen][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a]
set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks]
set testblock [textblock::testblock 15 rainbow]
set testblock [textblock::testblock -size 15 rainbow]
set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks]
set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents]
}
@ -6206,9 +6282,11 @@ tcl::namespace::eval textblock {
set spec [string map [list <ftlist> $::textblock::frametypes] {
@id -id ::textblock::framedef
@cmd -name textblock::framedef\
-summary "Return frame graphical elements as a dictionary."\
-help "Return a dict of the elements that make up a frame border.
May return a subset of available elements based on memberglob values."
@leaders -min 0 -max 0
@opts
-joins -default "" -type list\
-help "List of join directions, any of: up down left right
or those combined with another frametype e.g left-heavy down-light."
@ -6216,7 +6294,7 @@ tcl::namespace::eval textblock {
-help "-boxonly true restricts results to the corner,vertical and horizontal box elements
It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj."
@values -min 1
@values -min 1 -max -1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary."
memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
@ -7619,7 +7697,7 @@ tcl::namespace::eval textblock {
} -help "Perform an action on the frame cache."
}
proc frame_cache {args} {
set argd [punk::args::get_by_id ::textblock::frame_cache $args]
set argd [punk::args::parse $args withid ::textblock::frame_cache]
set action [dict get $argd values action]
variable frame_cache
set all_values_dict [dict get $argd values]
@ -7664,7 +7742,7 @@ tcl::namespace::eval textblock {
endindex -default "" -type indexexpression
}
proc frame_cache_display {args} {
set argd [punk::args::get_by_id ::textblock::frame_cache_display $args]
set argd [punk::args::parse $args withid ::textblock::frame_cache_display]
variable frame_cache
lassign [dict values [dict get $argd values]] startidx endidx
set limit ""
@ -7769,11 +7847,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 +7875,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 +7934,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 +7982,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 ""
@ -7928,7 +8025,6 @@ tcl::namespace::eval textblock {
#never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame
if {[llength $args] != 1 && (!$opts_ok || $check_args)} {
#as frame is called a lot within table building - checking args can have a *big* impact on final performance.
#set argd [punk::args::get_by_id ::textblock::frame $args]
set argd [punk::args::parse $args withid ::textblock::frame]
set opts [dict get $argd opts]
set contents [dict get $argd values contents]
@ -8530,7 +8626,8 @@ tcl::namespace::eval textblock {
#puts "frame--->ansiwrap -rawansi [ansistring VIEW $opt_ansibase] $cache_inner"
if {$opt_ansibase ne ""} {
if {[punk::ansi::ta::detect $cache_inner]} {
set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner]
#set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner]
set cache_inner [punk::ansi::ansiwrap_raw $opt_ansibase "" "" $cache_inner]
} else {
set cache_inner "$opt_ansibase$cache_inner\x1b\[0m"
}
@ -8561,7 +8658,8 @@ tcl::namespace::eval textblock {
#JMN test
#assert - lhs, cache_inner, rhs non-ragged - so can use join_basic REVIEW
#set cache_body [textblock::join -- {*}$cache_bodyparts]
set cache_body [textblock::join_basic -- {*}$cache_bodyparts]
#set cache_body [textblock::join_basic -- {*}$cache_bodyparts]
set cache_body [textblock::join_basic_raw {*}$cache_bodyparts]
append fscached $cache_body
#append fs $body
@ -8622,7 +8720,8 @@ tcl::namespace::eval textblock {
set contents_has_ansi [punk::ansi::ta::detect $contents]
if {$opt_ansibase ne ""} {
if {$contents_has_ansi} {
set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents]
#set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents]
set contents [punk::ansi::ansiwrap_raw $opt_ansibase "" "" $contents]
} else {
set contents "$opt_ansibase$contents\x1b\[0m"
set contents_has_ansi 1

4
src/bootsupport/modules_tcl8/include_modules.config

@ -5,6 +5,8 @@
#each entry - base module
set bootsupport_modules [list\
modules_tcl8 thread\
modules_tcl8/thread/platform *\
modules_tcl8 thread::platform::win32_x86_64_tcl8\
]
# modules_tcl8/thread/platform *\

BIN
src/bootsupport/modules_tcl8/thread/platform/win32_x86_64_tcl8-2.8.9.tm

Binary file not shown.

85
src/make.tcl

@ -181,16 +181,18 @@ set startdir [pwd]
# -------------------------------------------------------------------------------------
set bootsupport_module_paths [list]
set bootsupport_library_paths [list]
#we always create these lists in order of desired precedence.
# - this is the same order when adding to auto_path - but will need to be reversed when using tcl:tm::add
if {[file exists [file join $startdir src bootsupport]]} {
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order
lappend bootsupport_module_paths [file join $startdir src bootsupport modules]
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv]
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $startdir src bootsupport lib]
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv]
} else {
lappend bootsupport_module_paths [file join $startdir bootsupport modules]
lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv]
lappend bootsupport_library_paths [file join $startdir bootsupport lib]
lappend bootsupport_module_paths [file join $startdir bootsupport modules]
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv]
lappend bootsupport_library_paths [file join $startdir bootsupport lib]
}
set bootsupport_paths_exist 0
foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] {
@ -210,13 +212,13 @@ set sourcesupport_paths_exist 0
#(most?) Modules in src/modules etc should still be runnable directly in certain cases like this where we point to them.
if {[file tail $startdir] eq "src"} {
#todo - other src 'module' dirs..
foreach p [list $startdir/modules $startdir/modules_tcl$::tclmajorv $startdir/vendormodules $startdir/vendormodules_tcl$::tclmajorv] {
foreach p [list $startdir/modules_tcl$::tclmajorv $startdir/modules $startdir/vendormodules_tcl$::tclmajorv $startdir/vendormodules] {
if {[file exists $p]} {
lappend sourcesupport_module_paths $p
}
}
# -- -- --
foreach p [list $startdir/lib $startdir/lib_tcl$::tclmajorv $startdir/vendorlib $startdir/vendorlib_tcl$::tclmajorv] {
foreach p [list $startdir/lib_tcl$::tclmajorv $startdir/lib $startdir/vendorlib_tcl$::tclmajorv $startdir/vendorlib] {
if {[file exists $p]} {
lappend sourcesupport_library_paths $p
}
@ -273,16 +275,48 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
package forget $pkg
}
}
#tcl::tm::add {*}$original_tm_list {*}$bootsupport_module_paths {*}$sourcesupport_module_paths
#set ::auto_path [list {*}$original_auto_path {*}$bootsupport_library_paths {*}$sourcesupport_library_paths]
tcl::tm::add {*}$bootsupport_module_paths {*}$sourcesupport_module_paths
set ::auto_path [list {*}$bootsupport_library_paths {*}$sourcesupport_library_paths]
#Deliberately omit original_tm_list and original_auto_path
tcl::tm::add {*}[lreverse $bootsupport_module_paths] {*}[lreverse $sourcesupport_module_paths] ;#tm::add works like LIFO. sourcesupport_module_paths end up earliest in resulting tm list.
set ::auto_path [list {*}$sourcesupport_library_paths {*}$bootsupport_library_paths]
}
puts "----> auto_path $::auto_path"
puts "----> tcl::tm::list [tcl::tm::list]"
#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"
}
}
#--------------------------------------------------------
#package require Thread
puts "---->tcl_library [info library]"
puts "---->loaded [info loaded]"
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly.
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list
@ -297,6 +331,8 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
package require punk::lib
package require punk::args
package require punk::ansi
package require textblock
set package_paths_modified 1
@ -1218,14 +1254,19 @@ if {$::punkboot::command eq "check"} {
}
# -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
# - package path restore original module paths and auto_path entries to take effect in addition to bootsupport paths
# - Order such that bootsupport entries are always higher priority (if same version number - prefer bootsupport)
# - This must be done between the two "check" command sections
if {$package_paths_modified} {
set tm_list_now [tcl::tm::list]
foreach p $original_tm_list {
if {$p ni $tm_list_now} {
set tm_list_boot [tcl::tm::list]
tcl::tm::remove {*}$tm_list_boot
foreach p [lreverse $original_tm_list] {
if {$p ni $tm_list_boot} {
tcl::tm::add $p
}
}
foreach p [lreverse $tm_list_boot] {
tcl::tm::add $p
}
#set ::auto_path [list $bootsupport_lib {*}$original_auto_path]
lappend ::auto_path {*}$original_auto_path
}
@ -1333,11 +1374,13 @@ if {$::punkboot::command eq "info"} {
if {$::punkboot::command eq "shell"} {
puts stderr ">>>>>> loaded:[info loaded]"
package require punk
package require punk::repl
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell"
#todo - make procs vars etc from this file available?
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell."
repl::init
repl::start stdin
@ -1504,7 +1547,7 @@ if {$::punkboot::command eq "bootsupport"} {
proc modfile_sort {p1 p2} {
lassign [split [file rootname $p1] -] _ v1
lassign [split [file rootname $p1] -] _ v2
lassign [split [file rootname $p2] -] _ v2
package vcompare $v1 $v2
}
proc bootsupport_localupdate {projectroot} {
@ -1543,7 +1586,10 @@ if {$::punkboot::command eq "bootsupport"} {
set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]]
set srclocation [file join $projectroot $relpath $module_subpath]
#puts stdout "$relpath $modulematch $module_subpath $srclocation"
if {[string first - $modulematch]} {
#we must always glob using the dash - or we will match libraries that are suffixes of others
#bare lib.tm with no version is not valid.
if {[string first - $modulematch] != -1} {
#version or part thereof is specified.
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm]
} else {
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm]
@ -1566,6 +1612,7 @@ if {$::punkboot::command eq "bootsupport"} {
#review
set copy_files $pkgmatches
}
#if a file added manually to target dir - there will be no .punkcheck record - will be detected as changed
foreach cfile $copy_files {
set srcfile [file join $srclocation $cfile]
set tgtfile [file join $targetroot $module_subpath $cfile]
@ -1574,6 +1621,8 @@ if {$::punkboot::command eq "bootsupport"} {
$boot_event targetset_init INSTALL $tgtfile
$boot_event targetset_addsource $srcfile
#----------
#
#puts "bootsuport target $tgtfile record size: [dict size [$boot_event targetset_last_complete]]"
if {\
[llength [dict get [$boot_event targetset_source_changes] changed]]\
|| [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\

38
src/modules/punk/libunknown-0.1.tm

@ -849,19 +849,21 @@ tcl::namespace::eval punk::libunknown {
dict for {pkg versiond} $refresh_dict {
set versions [dict keys $versiond]
puts stderr "---->pkg:$pkg versions: $versions"
foreach searchpath $ordered_searchpaths {
set addedinfo [dict get $dict_added $searchpath]
set vidx -1
foreach v $versions {
incr vidx
if {[dict exists $addedinfo $pkg $v]} {
ledit versions $vidx $vidx
ledit versions $vidx $vidx ;incr vidx -1 ;#maintain vidx as index into current state of $versions - not original state the foreach operates across.
set iscript [dict get $addedinfo $pkg $v scr]
#todo - find the iscript in the '$epoch pkg epochs <e> added paths' lists and determine os vs dev vs internal
#(scanning for path directly in the ifneeded script for pkgs is potentially error prone)
#for .tm ifneeded scripts - the syntax is simple enough to determine directly (and ifneeded scr not stored for those anyway)
if {[package ifneeded $pkg $v] ne $iscript} {
#puts "---->refreshing $pkg $v - reverting to already stored from path:$searchpath"
set justaddedscript [package ifneeded $pkg $v]
if {$justaddedscript ne $iscript} {
puts "---->refreshing $pkg $v - reverting to already stored from path:$searchpath versions: $versions"
package ifneeded $pkg $v $iscript
#dict set pkgvdone $pkg $v 1
}
@ -887,10 +889,10 @@ tcl::namespace::eval punk::libunknown {
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"
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
@ -1108,7 +1110,7 @@ tcl::namespace::eval punk::libunknown {
if {[string match ::* $pkg]} {
error "packagedb_indexinfo: package name required - not a fully qualified namespace beginning with :: Received:'$pkg'"
}
set versions [package versions $pkg]
set versions [lsort -command {package vcompare} [package versions $pkg]]
if {[llength $versions] == 0} {
set v [package provide $pkg]
}
@ -1519,9 +1521,25 @@ tcl::namespace::eval punk::libunknown {
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 tm_added [punk::lib::showdict [dict get $epoch tm epochs $tm_epoch added] */$pkgname]
set added [dict get $epoch tm epochs $tm_epoch added]
set rows [list]
dict for {path pkgs} $added {
set c1 $path
set c2 [dict size $pkgs]
set c3 ""
if {[dict exists $pkgs $pkgname]} {
set vdict [dict get $pkgs $pkgname]
dict for {v data} $vdict {
append c3 "$v $data" \n
}
}
set r [list $c1 $c2 $c3]
lappend rows $r
}
set title "TM epoch $tm_epoch - added"
set added [textblock::frame -title $title $tm_added]
#set added [textblock::frame -title $title $tm_added]
set added [textblock::table -title $title -headers [list Path Tmcount $pkgname] -rows $rows]
set tm_row $added

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

@ -53,11 +53,6 @@ namespace eval punk::mix::commandset::loadedlib {
#REVIEW - this doesn't result in full scans
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything
if {[catch {package require natsort}]} {
set has_natsort 0
} else {
set has_natsort 1
}
set packages [package names]
set matches [list]
foreach search $searchstrings {
@ -85,11 +80,7 @@ namespace eval punk::mix::commandset::loadedlib {
# set versions $v
#}
}
if {$has_natsort} {
set versions [natsort::sort $versions]
} else {
set versions [lsort $versions]
}
set versions [lsort -command {package vcompare} $versions]
if {$opt_highlight} {
set v [package provide $m]
if {$v ne ""} {
@ -188,11 +179,6 @@ namespace eval punk::mix::commandset::loadedlib {
}
proc info {libname} {
if {[catch {package require natsort}]} {
set has_natsort 0
} else {
set has_natsort 1
}
catch {package require $libname 1-0} ;#ensure pkg system has loaded/searched - using unsatisfiable version range
set pkgsknown [package names]
if {[set posn [lsearch $pkgsknown $libname]] >= 0} {
@ -201,11 +187,7 @@ namespace eval punk::mix::commandset::loadedlib {
puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path"
}
set versions [package versions [lindex $libname 0]]
if {$has_natsort} {
set versions [natsort::sort $versions]
} else {
set versions [lsort $versions]
}
set versions [lsort -command {package vcompare} $versions]
if {![llength $versions]} {
puts stderr "No version numbers found for library/module $libname"
return false

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

@ -592,10 +592,23 @@ namespace eval punk::mix::commandset::project {
namespace export *
namespace path [namespace parent]
punk::args::define {
@id -id ::punk::mix::commandset::project::collection::_default
@cmd -name "punk::mix::commandset::project::collection::_default"\
-summary\
"List projects under fossil managment."\
-help\
"List projects under fossil management, showing fossil db location and number of checkouts"
@values -min 0 -max -1
glob -type string -multiple 1 -default *
}
#e.g imported as 'projects'
proc _default {{glob {}} args} {
proc _default {args} {
set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default]
set globlist [dict get $argd values glob]
#*** !doctools
#[call [fun _default] [arg glob] [opt {option value...}]]
#[call [fun _default] [arg glob...]]
#[para]List projects under fossil management, showing fossil db location and number of checkouts
#[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied
#[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s
@ -604,7 +617,7 @@ namespace eval punk::mix::commandset::project {
#[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection
#[para]Will result in the command being available as <ensemblecommand> projects
package require overtype
set db_projects [lib::get_projects $glob]
set db_projects [lib::get_projects {*}$globlist]
set col1items [lsearch -all -inline -index 0 -subindices $db_projects *]
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *]
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *]
@ -1012,12 +1025,21 @@ namespace eval punk::mix::commandset::project {
#consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run
return [string cat % $tagname %]
}
#get project info only by opening the central confg-db
#(will not have proper project-name etc)
proc get_projects {{globlist {}} args} {
if {![llength $globlist]} {
set globlist [list *]
}
punk::args::define {
@id -id ::punk::mix::commandset::project::lib::get_projects
@cmd -name punk::mix::commandset::project::lib::get_projects\
-summary\
"List projects referred to by central fossil config-db."\
-help\
"Get project info only by opening the central fossil config-db
(will not have proper project-name etc)"
@values -min 0 -max -1
glob -type string -multiple 1 -default * -optional 1
}
proc get_projects {args} {
set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects]
set globlist [dict get $argd values glob]
set fossil_prog [auto_execok fossil]
set configdb [punk::repo::fossil_get_configdb]

2
src/modules/punk/repl-999999.0a1.0.tm

@ -3362,7 +3362,7 @@ namespace eval repl {
#work around bug in safe base which won't load Tcl libs that have deeper nesting
#(also affects tcllib page/plugins folder)
set termversions [package versions term]
set termversions [lsort -command {package vcompare} [package versions term]]
set termv [lindex $termversions end]
if {$termv ne ""} {
set path [lindex [package ifneeded term $termv] end] ;#assuming path at end of something like "source .../term.tcl"

8
src/modules/punkcheck-0.1.0.tm

@ -243,14 +243,10 @@ namespace eval punkcheck {
}
method get_targets_exist {} {
set punkcheck_folder [file dirname [$o_installer get_checkfile]]
#puts stdout "### punkcheck glob -dir $punkcheck_folder -tails {*}$o_targets"
#targets can be paths such as punk/mix/commandset/module-0.1.0.tm - glob can search levels below supplied -dir
set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets]
#set existing [list]
#foreach t $o_targets {
# if {[file exists [file join $punkcheck_folder $t]]} {
# lappend existing $t
# }
#}
return $existing
}
method end {} {

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

@ -181,16 +181,18 @@ set startdir [pwd]
# -------------------------------------------------------------------------------------
set bootsupport_module_paths [list]
set bootsupport_library_paths [list]
#we always create these lists in order of desired precedence.
# - this is the same order when adding to auto_path - but will need to be reversed when using tcl:tm::add
if {[file exists [file join $startdir src bootsupport]]} {
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order
lappend bootsupport_module_paths [file join $startdir src bootsupport modules]
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv]
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $startdir src bootsupport lib]
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv]
} else {
lappend bootsupport_module_paths [file join $startdir bootsupport modules]
lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv]
lappend bootsupport_library_paths [file join $startdir bootsupport lib]
lappend bootsupport_module_paths [file join $startdir bootsupport modules]
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv]
lappend bootsupport_library_paths [file join $startdir bootsupport lib]
}
set bootsupport_paths_exist 0
foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] {
@ -210,13 +212,13 @@ set sourcesupport_paths_exist 0
#(most?) Modules in src/modules etc should still be runnable directly in certain cases like this where we point to them.
if {[file tail $startdir] eq "src"} {
#todo - other src 'module' dirs..
foreach p [list $startdir/modules $startdir/modules_tcl$::tclmajorv $startdir/vendormodules $startdir/vendormodules_tcl$::tclmajorv] {
foreach p [list $startdir/modules_tcl$::tclmajorv $startdir/modules $startdir/vendormodules_tcl$::tclmajorv $startdir/vendormodules] {
if {[file exists $p]} {
lappend sourcesupport_module_paths $p
}
}
# -- -- --
foreach p [list $startdir/lib $startdir/lib_tcl$::tclmajorv $startdir/vendorlib $startdir/vendorlib_tcl$::tclmajorv] {
foreach p [list $startdir/lib_tcl$::tclmajorv $startdir/lib $startdir/vendorlib_tcl$::tclmajorv $startdir/vendorlib] {
if {[file exists $p]} {
lappend sourcesupport_library_paths $p
}
@ -273,16 +275,48 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
package forget $pkg
}
}
#tcl::tm::add {*}$original_tm_list {*}$bootsupport_module_paths {*}$sourcesupport_module_paths
#set ::auto_path [list {*}$original_auto_path {*}$bootsupport_library_paths {*}$sourcesupport_library_paths]
tcl::tm::add {*}$bootsupport_module_paths {*}$sourcesupport_module_paths
set ::auto_path [list {*}$bootsupport_library_paths {*}$sourcesupport_library_paths]
#Deliberately omit original_tm_list and original_auto_path
tcl::tm::add {*}[lreverse $bootsupport_module_paths] {*}[lreverse $sourcesupport_module_paths] ;#tm::add works like LIFO. sourcesupport_module_paths end up earliest in resulting tm list.
set ::auto_path [list {*}$sourcesupport_library_paths {*}$bootsupport_library_paths]
}
puts "----> auto_path $::auto_path"
puts "----> tcl::tm::list [tcl::tm::list]"
#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"
}
}
#--------------------------------------------------------
#package require Thread
puts "---->tcl_library [info library]"
puts "---->loaded [info loaded]"
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly.
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list
@ -297,6 +331,8 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
package require punk::lib
package require punk::args
package require punk::ansi
package require textblock
set package_paths_modified 1
@ -1218,14 +1254,19 @@ if {$::punkboot::command eq "check"} {
}
# -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
# - package path restore original module paths and auto_path entries to take effect in addition to bootsupport paths
# - Order such that bootsupport entries are always higher priority (if same version number - prefer bootsupport)
# - This must be done between the two "check" command sections
if {$package_paths_modified} {
set tm_list_now [tcl::tm::list]
foreach p $original_tm_list {
if {$p ni $tm_list_now} {
set tm_list_boot [tcl::tm::list]
tcl::tm::remove {*}$tm_list_boot
foreach p [lreverse $original_tm_list] {
if {$p ni $tm_list_boot} {
tcl::tm::add $p
}
}
foreach p [lreverse $tm_list_boot] {
tcl::tm::add $p
}
#set ::auto_path [list $bootsupport_lib {*}$original_auto_path]
lappend ::auto_path {*}$original_auto_path
}
@ -1333,11 +1374,13 @@ if {$::punkboot::command eq "info"} {
if {$::punkboot::command eq "shell"} {
puts stderr ">>>>>> loaded:[info loaded]"
package require punk
package require punk::repl
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell"
#todo - make procs vars etc from this file available?
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell."
repl::init
repl::start stdin
@ -1504,7 +1547,7 @@ if {$::punkboot::command eq "bootsupport"} {
proc modfile_sort {p1 p2} {
lassign [split [file rootname $p1] -] _ v1
lassign [split [file rootname $p1] -] _ v2
lassign [split [file rootname $p2] -] _ v2
package vcompare $v1 $v2
}
proc bootsupport_localupdate {projectroot} {
@ -1543,7 +1586,10 @@ if {$::punkboot::command eq "bootsupport"} {
set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]]
set srclocation [file join $projectroot $relpath $module_subpath]
#puts stdout "$relpath $modulematch $module_subpath $srclocation"
if {[string first - $modulematch]} {
#we must always glob using the dash - or we will match libraries that are suffixes of others
#bare lib.tm with no version is not valid.
if {[string first - $modulematch] != -1} {
#version or part thereof is specified.
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm]
} else {
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm]
@ -1566,6 +1612,7 @@ if {$::punkboot::command eq "bootsupport"} {
#review
set copy_files $pkgmatches
}
#if a file added manually to target dir - there will be no .punkcheck record - will be detected as changed
foreach cfile $copy_files {
set srcfile [file join $srclocation $cfile]
set tgtfile [file join $targetroot $module_subpath $cfile]
@ -1574,6 +1621,8 @@ if {$::punkboot::command eq "bootsupport"} {
$boot_event targetset_init INSTALL $tgtfile
$boot_event targetset_addsource $srcfile
#----------
#
#puts "bootsuport target $tgtfile record size: [dict size [$boot_event targetset_last_complete]]"
if {\
[llength [dict get [$boot_event targetset_source_changes] changed]]\
|| [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\

37
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm

@ -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

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

@ -46,6 +46,7 @@ set bootsupport_modules [list\
modules punkcheck\
modules punkcheck::cli\
modules punk::aliascore\
modules punk::ansi::colourmap\
modules punk::ansi\
modules punk::assertion\
modules punk::args\
@ -61,6 +62,7 @@ set bootsupport_modules [list\
modules punk::fileline\
modules punk::docgen\
modules punk::lib\
modules punk::libunknown\
modules punk::mix\
modules punk::mix::base\
modules punk::mix::cli\

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

File diff suppressed because it is too large Load Diff

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

@ -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

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

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,966 @@
# -*- 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}]
#*** !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]

5868
src/bootsupport/modules/punk/args-0.1.9.tm → src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm

File diff suppressed because it is too large Load Diff

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

@ -449,7 +449,7 @@ tcl::namespace::eval punk::config {
Accepts globs eg XDG*"
@leaders -min 1 -max 1
#todo - load more whichconfig choices?
whichconfig -type string -choices {config startup-configuration running-configuration}
whichconfig -type any -choices {config startup-configuration running-configuration}
@values -min 0 -max -1
globkey -type string -default * -optional 1 -multiple 1
}]
@ -495,7 +495,7 @@ tcl::namespace::eval punk::config {
@cmd -name punk::config::configure -help\
"Get/set configuration values from a config"
@leaders -min 1 -max 1
whichconfig -type string -choices {defaults startup-configuration running-configuration}
whichconfig -type any -choices {defaults startup-configuration running-configuration}
@values -min 0 -max 2
key -type string -optional 1
newvalue -optional 1

21
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm

@ -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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm

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

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

@ -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 [llength $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 [llength $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
@ -695,14 +741,15 @@ namespace eval punk::lib {
proc lswap {lvar a z} {
upvar $lvar l
if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} {
set len [llength $l]
if {[lindex_resolve_basic $len $a] < 0 || [lindex_resolve_basic $len $z] < 0} {
#lindex_resolve_basic returns only -1 if out of range
#if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred
#(e.g using: lswap mylist end-2 end on a two element list)
#on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report
#use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned)
set a_index [lindex_resolve $l $a]
set a_index [lindex_resolve $len $a]
set a_msg ""
switch -- $a_index {
-2 {
@ -712,7 +759,7 @@ namespace eval punk::lib {
set a_msg "1st supplied index $a is below the lower bound for the list (0)"
}
}
set z_index [lindex_resolve $l $z]
set z_index [lindex_resolve $len $z]
set z_msg ""
switch -- $z_index {
-2 {
@ -1100,7 +1147,7 @@ namespace eval punk::lib {
- then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator.
e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1
Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent
The second level segement in each pattern switches to a dict operation to retrieve the value by key.
The second level segment in each pattern switches to a dict operation to retrieve the value by key.
When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level.
}
}]
@ -1137,11 +1184,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 +1222,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"
@ -1465,7 +1515,7 @@ namespace eval punk::lib {
if {![regexp $re_idxdashidx $p _match a b]} {
error "unrecognised pattern $p"
}
set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high
set lower_resolve [punk::lib::lindex_resolve [llength $dval] $a] ;#-2 for too low, -1 for too high
#keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds
if {${lower_resolve} == -2} {
##x
@ -1478,7 +1528,7 @@ namespace eval punk::lib {
} else {
set lower $lower_resolve
}
set upper [punk::lib::lindex_resolve $dval $b]
set upper [punk::lib::lindex_resolve [llength $dval] $b]
if {$upper == -3} {
##x
#upper bound is below list range -
@ -1831,7 +1881,8 @@ namespace eval punk::lib {
if {$last_hidekey} {
append result \n
}
append result [textblock::join_basic -- $kblock $sblock $vblock] \n
#append result [textblock::join_basic -- $kblock $sblock $vblock] \n
append result [textblock::join_basic_raw $kblock $sblock $vblock] \n
}
set last_hidekey $hidekey
incr kidx
@ -1880,6 +1931,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 +1952,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 +1975,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 +1992,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]
@ -2158,35 +2242,75 @@ namespace eval punk::lib {
}
}
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side
proc lindex_resolve {list index} {
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bounds on upper vs lower side
#REVIEW: This shouldn't really need the list itself - just the length would suffice
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 or string length."\
-help\
"Resolve an index which may be of the forms accepted by Tcl list or string commands such as end-2 or 2+2
to the actual integer index for the supplied list/string length, or to a negative value below -1 indicating
whether the index was below or above the range of possible indices for the length supplied.
Users may define procs which accept a list/string 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/string.
Otherwise it will return an integer corresponding to the position in the data.
This is in stark contrast to Tcl list/string 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/string (datalength 0), 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
datalength -type integer
index -type indexexpression
}
proc lindex_resolve {len index} {
#*** !doctools
#[call [fun lindex_resolve] [arg list] [arg index]]
#[para]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
#[para]Users may define procs which accept a list index and wish to accept the forms understood by Tcl.
#[call [fun lindex_resolve] [arg len] [arg index]]
#[para]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/string length
#[para]Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl.
#[para]This means the proc may be called with something like $x+2 end-$y etc
#[para]Sometimes the actual integer index is desired.
#[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks.
#[para]lindex_resolve will parse the index expression and return:
#[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0)
#[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] 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/string
#[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 ???
#}
if {![string is integer -strict $len]} {
#<0 ?
error "lindex_resolve len must be an integer"
}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
if {$index < 0} {
return -3
} elseif {$index >= [llength $list]} {
} elseif {$index >= $len} {
return -2
} else {
#integer may still have + sign - normalize with expr
@ -2203,7 +2327,7 @@ namespace eval punk::lib {
}
} else {
#index is 'end'
set index [expr {[llength $list]-1}]
set index [expr {$len-1}]
if {$index < 0} {
#special case - 'end' with empty list - treat end like a positive number out of bounds
return -2
@ -2212,7 +2336,7 @@ namespace eval punk::lib {
}
}
if {$offset == 0} {
set index [expr {[llength $list]-1}]
set index [expr {$len-1}]
if {$index < 0} {
return -2 ;#special case as above
} else {
@ -2220,7 +2344,7 @@ namespace eval punk::lib {
}
} else {
#by now, if op = + then offset = 0 so we only need to handle the minus case
set index [expr {([llength $list]-1) - $offset}]
set index [expr {($len-1) - $offset}]
}
if {$index < 0} {
return -3
@ -2245,33 +2369,32 @@ namespace eval punk::lib {
}
if {$index < 0} {
return -3
} elseif {$index >= [llength $list]} {
} elseif {$index >= $len} {
return -2
}
return $index
}
}
}
proc lindex_resolve_basic {list index} {
proc lindex_resolve_basic {len index} {
#*** !doctools
#[call [fun lindex_resolve_basic] [arg list] [arg index]]
#[call [fun lindex_resolve_basic] [arg len] [arg index]]
#[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2)
#[para] returns -1 for out of range at either end, or a valid integer index
#[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound
#[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command
#[para] This is only likely to be faster than average over lindex_resolve for small lists and for Tcl which has the builtin lseq command
#[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1
#[para] For pure integer indices the performance should be equivalent
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+
# - which
#for {set i 0} {$i < [llength $list]} {incr i} {
# lappend indices $i
#}
if {![string is integer -strict $len]} {
error "lindex_resolve_basic len must be an integer"
}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
#avoid even the lseq overhead when the index is simple
if {$index < 0 || ($index >= [llength $list])} {
if {$index < 0 || ($index >= $len)} {
#even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method.
return -1
} else {
@ -2279,13 +2402,15 @@ namespace eval punk::lib {
return [expr {$index}]
}
}
if {[llength $list]} {
set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback.
#if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?)
if {$len > 0} {
#For large len - this is a wasteful allocation if no true lseq available in Tcl version.
#lseq produces an 'arithseries' object which we can index into without allocating an entire list (REVIEW)
set testlist [punk::lib::range 0 [expr {$len-1}]] ;# uses lseq if available, has fallback.
} else {
set indices [list]
set testlist [list]
#we want to call 'lindex' even in this case - to get the appropriate error message
}
set idx [lindex $indices $index]
set idx [lindex $testlist $index]
if {$idx eq ""} {
#we have no way to determine if out of bounds is at lower vs upper end
return -1
@ -2304,6 +2429,81 @@ namespace eval punk::lib {
}
}
proc string_splitbefore {str index} {
if {![string is integer -strict $index]} {
set index [punk::lib::lindex_resolve [string length $str] $index]
switch -- $index {
-2 {
return [list $str ""]
}
-3 {
return [list "" $str]
}
}
}
return [list [string range $str 0 $index-1] [string range $str $index end]]
#scan %s stops at whitespace - not useful here.
#scan $s %${p}s%s
}
proc string_splitbefore_indices {str args} {
set parts [list $str]
set sizes [list [string length $str]]
set s 0
foreach index $args {
if {![string is integer -strict $index]} {
set index [punk::lib::lindex_resolve [string length $str] $index]
switch -- $index {
-2 {
if {[lindex $sizes end] != 0} {
ledit parts end end [lindex $parts end] {}
ledit sizes end end [lindex $sizes end] 0
}
continue
}
-3 {
if {[lindex $sizes 0] != 0} {
ledit parts 0 0 {} [lindex $parts 0]
ledit sizes 0 0 0 [lindex $sizes 0]
}
continue
}
}
}
if {$index <= 0} {
if {[lindex $sizes 0] != 0} {
ledit parts 0 0 {} [lindex $parts 0]
ledit sizes 0 0 0 [lindex $sizes 0]
}
continue
}
if {$index >= [string length $str]} {
if {[lindex $sizes end] != 0} {
ledit parts end end [lindex $parts end] {}
ledit sizes end end [lindex $sizes end] 0
}
continue
}
set i -1
set a 0
foreach sz $sizes {
incr i
if {$a + $sz > $index} {
set p [lindex $parts $i]
#puts "a:$a index:$index"
if {$a == $index} {
break
}
ledit parts $i $i [string range $p 0 [expr {$index -$a -1}]] [string range $p $index-$a end]
ledit sizes $i $i [expr {$index - $a}] [expr {($a + $sz)-$index}]
break
}
incr a $sz
}
#puts "->parts:$parts"
#puts "->sizes:$sizes"
}
return $parts
}
proc K {x y} {return $x}
#*** !doctools
@ -3133,8 +3333,7 @@ namespace eval punk::lib {
#Each resulting line should have a reset of some type at start and a pure-reset at end to stop
#see if we can find an ST sequence that most terminals will not display for marking sections?
if {$opt_ansireplays} {
#package require punk::ansi
<require_punk_ansi>
<require_punk_ansi> ;#package require punk::ansi
if {$opt_ansiresets} {
set RST "\x1b\[0m"
} else {

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

File diff suppressed because it is too large Load Diff

22
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm

@ -53,11 +53,6 @@ namespace eval punk::mix::commandset::loadedlib {
#REVIEW - this doesn't result in full scans
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything
if {[catch {package require natsort}]} {
set has_natsort 0
} else {
set has_natsort 1
}
set packages [package names]
set matches [list]
foreach search $searchstrings {
@ -85,11 +80,7 @@ namespace eval punk::mix::commandset::loadedlib {
# set versions $v
#}
}
if {$has_natsort} {
set versions [natsort::sort $versions]
} else {
set versions [lsort $versions]
}
set versions [lsort -command {package vcompare} $versions]
if {$opt_highlight} {
set v [package provide $m]
if {$v ne ""} {
@ -188,11 +179,6 @@ namespace eval punk::mix::commandset::loadedlib {
}
proc info {libname} {
if {[catch {package require natsort}]} {
set has_natsort 0
} else {
set has_natsort 1
}
catch {package require $libname 1-0} ;#ensure pkg system has loaded/searched - using unsatisfiable version range
set pkgsknown [package names]
if {[set posn [lsearch $pkgsknown $libname]] >= 0} {
@ -201,11 +187,7 @@ namespace eval punk::mix::commandset::loadedlib {
puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path"
}
set versions [package versions [lindex $libname 0]]
if {$has_natsort} {
set versions [natsort::sort $versions]
} else {
set versions [lsort $versions]
}
set versions [lsort -command {package vcompare} $versions]
if {![llength $versions]} {
puts stderr "No version numbers found for library/module $libname"
return false

9
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm

@ -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]

40
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm

@ -592,10 +592,23 @@ namespace eval punk::mix::commandset::project {
namespace export *
namespace path [namespace parent]
punk::args::define {
@id -id ::punk::mix::commandset::project::collection::_default
@cmd -name "punk::mix::commandset::project::collection::_default"\
-summary\
"List projects under fossil managment."\
-help\
"List projects under fossil management, showing fossil db location and number of checkouts"
@values -min 0 -max -1
glob -type string -multiple 1 -default *
}
#e.g imported as 'projects'
proc _default {{glob {}} args} {
proc _default {args} {
set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default]
set globlist [dict get $argd values glob]
#*** !doctools
#[call [fun _default] [arg glob] [opt {option value...}]]
#[call [fun _default] [arg glob...]]
#[para]List projects under fossil management, showing fossil db location and number of checkouts
#[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied
#[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s
@ -604,7 +617,7 @@ namespace eval punk::mix::commandset::project {
#[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection
#[para]Will result in the command being available as <ensemblecommand> projects
package require overtype
set db_projects [lib::get_projects $glob]
set db_projects [lib::get_projects {*}$globlist]
set col1items [lsearch -all -inline -index 0 -subindices $db_projects *]
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *]
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *]
@ -1012,12 +1025,21 @@ namespace eval punk::mix::commandset::project {
#consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run
return [string cat % $tagname %]
}
#get project info only by opening the central confg-db
#(will not have proper project-name etc)
proc get_projects {{globlist {}} args} {
if {![llength $globlist]} {
set globlist [list *]
}
punk::args::define {
@id -id ::punk::mix::commandset::project::lib::get_projects
@cmd -name punk::mix::commandset::project::lib::get_projects\
-summary\
"List projects referred to by central fossil config-db."\
-help\
"Get project info only by opening the central fossil config-db
(will not have proper project-name etc)"
@values -min 0 -max -1
glob -type string -multiple 1 -default * -optional 1
}
proc get_projects {args} {
set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects]
set globlist [dict get $argd values glob]
set fossil_prog [auto_execok fossil]
set configdb [punk::repo::fossil_get_configdb]

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

@ -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]

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

@ -177,10 +177,10 @@ tcl::namespace::eval punk::ns {
} else {
set fq_nspath $nspath
}
if {[catch {nseval_ifexists $fq_nspath {}}]} {
return 0
} else {
if {[nseval_ifexists $fq_nspath {::string cat ok}] eq "ok"} {
return 1
} else {
return 0
}
}
@ -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]
@ -757,13 +758,20 @@ tcl::namespace::eval punk::ns {
}
set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370]
if {[llength $ansinames]} {
return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type][punk::ansi::a]"
return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type]\x1b\[0m"
} else {
return [dict get $marks $type]
}
}
#REVIEW - ansi codes can be *very* confusing to the user when trying to handle lists etc..
punk::args::define {
@id -id ::punk::ns::get_nslist
@cmd -name punk::ns::get_nslist
@opts
-match -default ""
-nsdict -type dict -default {}
}
proc get_nslist {args} {
set known_types [list children commands exported imported aliases procs ensembles ooclasses ooobjects ooprivateobjects ooprivateclasses native coroutines interps zlibstreams]
set defaults [dict create\
@ -774,6 +782,9 @@ tcl::namespace::eval punk::ns {
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- ---
set fq_glob [dict get $opts -match]
if {$fq_glob eq ""} {
set fq_glob [uplevel 1 nsthis]::*
}
set requested_types [dict get $opts -types]
set opt_nsdict [dict get $opts -nsdict]
@ -834,7 +845,7 @@ tcl::namespace::eval punk::ns {
set zlibstreams [list]
set usageinfo [list]
if {$opt_nsdict eq ""} {
if {![dict size $opt_nsdict]} {
set nsmatches [get_ns_dicts $fq_glob -allbelow 0]
set itemcount 0
set matches_with_results [list]
@ -866,6 +877,8 @@ tcl::namespace::eval punk::ns {
}
if {"commands" in $types} {
set commands [dict get $contents commands]
}
set usageinfo [dict get $contents usageinfo]
foreach t $types {
switch -- $t {
exported {
@ -909,8 +922,6 @@ tcl::namespace::eval punk::ns {
}
}
}
set usageinfo [dict get $contents usageinfo]
}
set numchildren [llength $children]
if {$numchildren} {
@ -1067,7 +1078,7 @@ tcl::namespace::eval punk::ns {
} else {
}
if {$cmd in $imported} {
set prefix [overtype::right $prefix "-[a+ yellow bold]I[a+]"]
set prefix [overtype::right $prefix "-[a+ yellow bold]I[a]"]
}
}
if {$cmd in $usageinfo} {
@ -1075,7 +1086,8 @@ tcl::namespace::eval punk::ns {
} else {
set u ""
}
set cmd$i "${prefix} $c$cmd_display$u"
#set cmd$i "${prefix} $c$cmd_display$u"
set cmd$i "${prefix} [punk::ansi::ansiwrap -rawansi $c $cmd_display]$u"
#set c$i $c
set c$i ""
lappend seencmds $cmd
@ -1146,7 +1158,11 @@ tcl::namespace::eval punk::ns {
the child namespaces and commands within
the namespace(s) matched by glob."
@opts
-nspathcommands -type boolean -default 0
-nspathcommands -type boolean -default 0 -help\
"When a namespace has entries configured in 'namespace path', the default result for nslist
will display just a basic note: 'Also resolving cmds in namespace paths: <namespaces>'.
If -nspathcommands is true, it will also display subtables showing the commands resolvable
via any such listed namespaces."
-types
@values -min 0 -max -1
glob -multiple 1 -optional 1 -default "*"
@ -1205,9 +1221,9 @@ tcl::namespace::eval punk::ns {
if {[dict size [dict get $nsdict namespacepath]]} {
set path_text ""
if {!$opt_nspathcommands} {
append path_text \n " also resolving cmds in namespace paths: [dict keys [dict get $nsdict namespacepath]]"
append path_text \n " Also resolving cmds in namespace paths: [dict keys [dict get $nsdict namespacepath]]"
} else {
append path_text \n " also resolving cmds in namespace paths:"
append path_text \n " Also resolving cmds in namespace paths:"
set nspathdict [dict get $nsdict namespacepath]
if {!$has_textblock} {
dict for {k v} $nspathdict {
@ -1216,8 +1232,14 @@ tcl::namespace::eval punk::ns {
append path_text \n " cmds: $cmds"
}
} else {
#todo - change to display in column order to be same as main command listing
dict for {k v} $nspathdict {
set t [textblock::list_as_table -title $k -columns 6 [lsort [dict get $v commands]]]
set pathcommands [dict get $v commands]
set columns 6
if {[llength $pathcommands] < 6} {
set columns [llength $v]
}
set t [textblock::list_as_table -title $k -columns $columns [lsort $pathcommands]]
append path_text \n $t
}
}
@ -1423,7 +1445,7 @@ tcl::namespace::eval punk::ns {
}
}
return $matches
}]
}]]
} else {
lappend matched {*}[tcl::namespace::eval $location [list ::info commands [nsjoin ${location} $p]]]
@ -2397,14 +2419,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 +2444,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 +2535,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 +2552,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 +2618,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 +2649,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 +2679,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 +2706,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 +2971,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 +3087,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 +3141,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 +3197,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 +3677,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
}
@ -3620,6 +3703,21 @@ tcl::namespace::eval punk::ns {
comment inserted to display information such as the
namespace origin. Such a comment begins with #corp#."
@opts
-syntax -default basic -choices {none basic}\
-choicelabels {
none\
" Plain text output"
basic\
" Comment and bracket highlights.
This is a basic colourizer - not
a full Tcl syntax highlighter."
}\
-help\
"Type of syntax highlighting on result.
Note that -syntax none will always return a proper Tcl
List: proc <name> <arglist> <body>
- but a syntax highlighter may return a string that
is not a Tcl list."
@values -min 1 -max -1
commandname -help\
"May be either the fully qualified path for the command,
@ -3629,6 +3727,7 @@ tcl::namespace::eval punk::ns {
proc corp {args} {
set argd [punk::args::parse $args withid ::punk::ns::corp]
set path [dict get $argd values commandname]
set syntax [dict get $argd opts -syntax]
#thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp
#Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name)
if {[info exists punk::console::tabwidth]} {
@ -3713,6 +3812,18 @@ tcl::namespace::eval punk::ns {
lappend argl $a
}
#list proc [nsjoin ${targetns} $name] $argl $body
switch -- $syntax {
basic {
#rudimentary colourising only
set argl [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl]
set body [punk::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one.
set body [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $body]
set body [punk::grepstr -return all -highlight tk-orange {\[|\]} $body]
#ansi colourised items in list format may not always have desired string representation (list escaping can occur)
#return as a string - which may not be a proper Tcl list!
return "proc $resolved {$argl} {\n$body\n}"
}
}
list proc $resolved $argl $body
}
@ -3799,13 +3910,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 +4034,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 +4074,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}

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

@ -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 {} {
@ -194,7 +194,7 @@ tcl::namespace::eval punk::packagepreference {
if {!$is_exact && [llength $vwant] <= 1 } {
#required version unspecified - or specified singularly
set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg]
if {[llength $available_versions] > 1} {
if {[llength $available_versions] >= 1} {
# ---------------------------------------------------------------
#An attempt to detect dll/so loaded and try to load same version
#dll/so files are often named with version numbers that don't contain dots or a version number at all
@ -202,9 +202,11 @@ tcl::namespace::eval punk::packagepreference {
set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg]
if {[llength $pkgloadedinfo]} {
puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available"
lassign $pkgloadedinfo path name
set lcpath [string tolower $path]
if {[llength $available_versions] > 1} {
puts stderr "--> pkg $pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and [llength $available_versions] versions available"
}
lassign $pkgloadedinfo loaded_path name
set lc_loadedpath [string tolower $loaded_path]
#first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement.
set lcpath_to_version [dict create]
foreach av $available_versions {
@ -212,17 +214,19 @@ tcl::namespace::eval punk::packagepreference {
#ifneeded script not always a valid tcl list
if {![catch {llength $scr} scrlen]} {
if {$scrlen == 3 && [lindex $scr 0] eq "load" && [string match -nocase [lindex $scr 2] $pkg]} {
#a basic 'load <path> <pkg>' statement
dict set lcpath_to_version [string tolower [lindex $scr 1]] $av
}
}
}
if {[dict exists $lcpath_to_version $lcpath]} {
set lversion [dict get $lcpath_to_version $lcpath]
if {[dict exists $lcpath_to_version $lc_loadedpath]} {
set lversion [dict get $lcpath_to_version $lc_loadedpath]
} else {
#fallback to a best effort guess based on the path
set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg]
set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $loaded_path $pkg]
}
#puts "====lcpath_to_version: $lcpath_to_version"
if {$lversion ne ""} {
#name matches pkg
#hack for known dll version mismatch
@ -232,24 +236,103 @@ tcl::namespace::eval punk::packagepreference {
if {[llength $vwant] == 1} {
#todo - still check vsatisfies - report a conflict? review
}
return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
#return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
try {
set result [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
} trap {} {emsg eopts} {
#REVIEW - this occurred in punkmagic (rebuild of tclmagic) - probably due to multiple versions of registry
#under different auto_path folders - and mal-ordering in punk::libunknown's tclPkgUnknown
#May be obsolete.. issue still not clear
#A hack for 'couldn't open "<path.dll>": permission denied'
#This happens for example with the tcl9registry13.dll when loading from zipfs - but not in all systems, and not for all dlls.
#exact cause unknown.
#e.g
#%package ifneeded registry 1.3.7
#- load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry
#%load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry
#couldn't open "C:/Users/sleek/AppData/Local/Temp/TCL00003cf8/tcl9registry13.dll": permission denied
#a subsequent load of the path used in the error message works.
#if {[string match "couldn't open \"*\": permission denied" $emsg]} {}
if {[regexp {couldn't open "(.*)":.*permission denied.*} $emsg _ newpath]} {
#Since this is a hack that shouldn't be required - be noisy about it.
puts stderr ">>> $emsg"
puts stderr "punk::packagepreference::require hack: Re-trying load of $pkg with path: $newpath"
return [load $newpath $pkg]
} else {
#puts stderr "??? $emsg"
#dunno - re-raise
return -options $eopts $emsg
}
}
return $result
}
#else puts stderr "> no version determined for pkg: $pkg loaded_path: $loaded_path"
}
}
}
# ---------------------------------------------------------------
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
#j2
$COMMANDSTACKNEXT require punk::args::$dp
}
}
#---------------------------------------------------------------
return $require_result
}
default {
return [$COMMANDSTACKNEXT {*}$args]

6
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm

@ -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

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

@ -373,6 +373,7 @@ tcl::namespace::eval punk::pipe::lib {
if {$end_var_posn > 0} {
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead.
#lassign [scan $token %${end_var_posn}s%s] var spec
#lassign [punk::lib::string_splitbefore $token $end_var_posn] var spec
set var [string range $token 0 $end_var_posn-1]
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec
} else {
@ -430,7 +431,7 @@ tcl::namespace::eval punk::pipe::lib {
}
#if {[string length $token]} {
# #lappend varlist [splitstrposn $token $end_var_posn]
# #lappend varlist [punk::lib::string_splitbefore $token $end_var_posn]
# set var $token
# set spec ""
# if {$end_var_posn > 0} {

2
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm

@ -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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm

@ -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

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

@ -243,14 +243,10 @@ namespace eval punkcheck {
}
method get_targets_exist {} {
set punkcheck_folder [file dirname [$o_installer get_checkfile]]
#puts stdout "### punkcheck glob -dir $punkcheck_folder -tails {*}$o_targets"
#targets can be paths such as punk/mix/commandset/module-0.1.0.tm - glob can search levels below supplied -dir
set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets]
#set existing [list]
#foreach t $o_targets {
# if {[file exists [file join $punkcheck_folder $t]]} {
# lappend existing $t
# }
#}
return $existing
}
method end {} {

3329
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.tm

File diff suppressed because it is too large Load Diff

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

@ -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
@ -154,7 +174,6 @@ tcl::namespace::eval textblock {
}
}
proc use_hash {args} {
#set argd [punk::args::get_by_id ::textblock::use_hash $args]
set argd [punk::args::parse $args withid ::textblock::use_hash]
variable use_hash
if {![dict exists $argd received hash_algorithm]} {
@ -2294,7 +2313,8 @@ tcl::namespace::eval textblock {
#JMN
#spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic
set spanned_frame [textblock::join_basic -- {*}$spanned_parts]
#set spanned_frame [textblock::join_basic -- {*}$spanned_parts]
set spanned_frame [textblock::join_basic_raw {*}$spanned_parts]
if {$spans_to_rhs} {
if {$cidx == 0} {
@ -2363,7 +2383,8 @@ tcl::namespace::eval textblock {
} else {
#this_span == 1
set spanned_frame [textblock::join_basic -- $header_cell_startspan]
#set spanned_frame [textblock::join_basic -- $header_cell_startspan]
set spanned_frame [textblock::join_basic_raw $header_cell_startspan]
}
@ -3992,7 +4013,8 @@ tcl::namespace::eval textblock {
set body_build ""
} else {
#body blocks should not be ragged - so can use join_basic
set body_build [textblock::join_basic -- {*}$body_blocks]
#set body_build [textblock::join_basic -- {*}$body_blocks]
set body_build [textblock::join_basic_raw {*}$body_blocks]
}
if {$headerheight > 0} {
set table [tcl::string::cat $header_build \n $body_build]
@ -4149,7 +4171,6 @@ tcl::namespace::eval textblock {
proc periodic {args} {
#For an impressive interactive terminal app (javascript)
# see: https://github.com/spirometaxas/periodic-table-cli
#set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts]
set opts [dict get [punk::args::parse $args withid ::textblock::periodic] opts]
set opt_return [tcl::dict::get $opts -return]
if {[tcl::dict::get $opts -forcecolour]} {
@ -4446,7 +4467,7 @@ tcl::namespace::eval textblock {
proc list_as_table {args} {
set FRAMETYPES [textblock::frametypes]
set argd [punk::args::get_by_id ::textblock::list_as_table $args]
set argd [punk::args::parse $args withid ::textblock::list_as_table]
set opts [dict get $argd opts]
set received [dict get $argd received]
@ -4644,7 +4665,8 @@ tcl::namespace::eval textblock {
if {[tcl::string::last \n $charblock] >= 0} {
if {$blockwidth > 1} {
#set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks )
set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]]
#set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]]
set row [textblock::join_basic_raw {*}[lrepeat $blockwidth $charblock]]
} else {
set row $charblock
}
@ -4694,7 +4716,7 @@ tcl::namespace::eval textblock {
}
proc testblock {args} {
set argd [punk::args::get_by_id ::textblock::testblock $args]
set argd [punk::args::parse $args withid ::textblock::testblock]
set colour [dict get $argd values colour]
set size [dict get $argd opts -size]
@ -4762,7 +4784,8 @@ tcl::namespace::eval textblock {
if {"noreset" in $colour} {
return [textblock::join_basic -ansiresets 0 -- {*}$clist]
} else {
return [textblock::join_basic -- {*}$clist]
#return [textblock::join_basic -- {*}$clist]
return [textblock::join_basic_raw {*}$clist]
}
} elseif {"rainbow" in $colour} {
#direction must be horizontal
@ -5019,19 +5042,20 @@ tcl::namespace::eval textblock {
-width ""\
-overflow 0\
-within_ansi 0\
-return block\
]
#known_samewidth of empty string means we don't know either way, 0 is definitely 'ragged', 1 is definitely homogenous
#review!?
#-within_ansi means after a leading ansi code when doing left pad on all but last line
#-within_ansi means before a trailing ansi code when doing right pad on all but last line
set usage "pad block ?-padchar <sp>|<character>? ?-which right|left|centre? ?-known_hasansi \"\"|<bool>? ?-known_blockwidth \"\"|<int>? ?-width auto|<int>? ?-within_ansi 1|0?"
foreach {k v} $args {
switch -- $k {
-padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi {
-padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi - -return {
tcl::dict::set opts $k $v
}
default {
set usage "pad block ?-padchar <sp>|<character>? ?-which right|left|centre? ?-known_hasansi \"\"|<bool>? ?-known_blockwidth \"\"|<int>? ?-width auto|<int>? ?-within_ansi 1|0? ?-return block|list?"
error "textblock::pad unrecognised option '$k'. Usage: $usage"
}
}
@ -5177,25 +5201,34 @@ tcl::namespace::eval textblock {
set line_len 0
set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad
foreach {pt ansi} $parts {
if {$pt ne ""} {
set has_nl [expr {[tcl::string::last \n $pt]>=0}]
if {$has_nl} {
if {$pt eq ""} {
#we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes
lappend line_chunks ""
} elseif {[tcl::string::last \n $pt]==-1} {
lappend line_chunks $pt
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
incr line_len [punk::char::grapheme_width_cached $pt] ;#memleak - REVIEW
}
} else {
#set has_nl [expr {[tcl::string::last \n $pt]>=0}]
#if {$has_nl} {
set pt [tcl::string::map [list \r\n \n] $pt]
set partlines [split $pt \n]
} else {
set partlines [list $pt]
}
set last [expr {[llength $partlines]-1}]
set p 0
foreach pl $partlines {
lappend line_chunks $pl
#} else {
# set partlines [list $pt]
#}
#set last [expr {[llength $partlines]-1}]
#set p -1
foreach pl [lrange $partlines 0 end-1] {
#incr p
lappend line_chunks $pl ;#we need to lappend because there can already be some pt and ansi entries for the current line from previous {pt ansi} values where pt had no newline.
#incr line_len [punk::char::ansifreestring_width $pl]
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
}
if {$p != $last} {
#if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
# incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
#}
#do padding
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
set missing [expr {$width - $line_len}]
} else {
set missing [expr {$width - $datawidth}]
@ -5258,15 +5291,20 @@ tcl::namespace::eval textblock {
set line_len 0
incr lnum
}
incr p
#deal with last part zzz of xxx\nyyy\nzzz - not yet a complete line
set pl [lindex $partlines end]
lappend line_chunks $pl ;#we need to lappend because there can already be some pt and ansi entries for the current line from previous {pt ansi} values where pt had no newline.
if {$pl ne "" && ($known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq "")} {
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
}
} else {
#we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes
lappend line_chunks ""
}
#don't let trailing empty ansi affect the line_chunks length
if {$ansi ne ""} {
lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content?
lappend line_chunks $ansi ;#don't update line_len
#- review - ansi codes with visible content?
#- There shouldn't be any, even though for example some terminals display PM content
#e.g OSC 8 is ok as it has the uri 'inside' the ansi sequence, but that's ok because the displayable part is outside and is one of our pt values from split_codes.
}
}
#pad last line
@ -5325,7 +5363,11 @@ tcl::namespace::eval textblock {
}
}
lappend lines [::join $line_chunks ""]
if {[tcl::dict::get $opts -return] eq "block"} {
return [::join $lines \n]
} else {
return $lines
}
}
#left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single
@ -5566,7 +5608,7 @@ tcl::namespace::eval textblock {
#join without regard to each line length in a block (no padding added to make each block uniform)
proc ::textblock::join_basic {args} {
set argd [punk::args::get_by_id ::textblock::join_basic $args]
set argd [punk::args::parse $args withid ::textblock::join_basic]
set ansiresets [tcl::dict::get $argd opts -ansiresets]
set blocks [tcl::dict::get $argd values blocks]
@ -5602,6 +5644,33 @@ tcl::namespace::eval textblock {
}
return [::join $outlines \n]
}
proc ::textblock::join_basic_raw {args} {
#no options. -*, -- are legimate blocks
set blocklists [lrepeat [llength $args] ""]
set blocklengths [lrepeat [expr {[llength $args]+1}] 0] ;#add 1 to ensure never empty - used only for rowcount max calc
set i -1
foreach b $args {
incr i
if {[punk::ansi::ta::detect $b]} {
#-ansireplays 1 quite expensive e.g 7ms in 2024
set blines [punk::lib::lines_as_list -ansireplays 1 -ansiresets auto -- $b]
} else {
set blines [split $b \n]
}
lset blocklengths $i [llength $blines]
lset blocklists $i $blines
}
set rowcount [tcl::mathfunc::max {*}$blocklengths]
set outlines [lrepeat $rowcount ""]
for {set r 0} {$r < $rowcount} {incr r} {
set row ""
foreach blines $blocklists {
append row [lindex $blines $r]
}
lset outlines $r $row
}
return [::join $outlines \n]
}
proc ::textblock::join_basic2 {args} {
#@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width.
# Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
@ -5686,9 +5755,12 @@ tcl::namespace::eval textblock {
}
set idx 0
set blocklists [list]
#set blocklists [list]
set blocklists [lrepeat [llength $blocks] ""]
set rowcount 0
set bidx -1
foreach b $blocks {
incr bidx
#we need the width of a rendered block for per-row renderline calls or padding
#we may as well use widthinfo to also determine raggedness state to pass on to pad function
#set bwidth [width $b]
@ -5705,18 +5777,21 @@ tcl::namespace::eval textblock {
if {[punk::ansi::ta::detect $b]} {
# - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?)
set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n]
set bl [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
#set blines [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
set blines [textblock::pad $replay_block -return lines -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "]
} else {
#each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi
set bl [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
#set blines [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
set blines [textblock::pad $b -return lines -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "]
}
set rowcount [expr {max($rowcount,[llength $bl])}]
lappend blocklists $bl
set rowcount [expr {max($rowcount,[llength $blines])}]
#lappend blocklists $bl
lset blocklists $bidx $blines
set width($idx) $bwidth
incr idx
}
set outlines [list]
set outlines [lrepeat $rowcount ""]
for {set r 0} {$r < $rowcount} {incr r} {
set row ""
for {set c 0} {$c < [llength $blocklists]} {incr c} {
@ -5726,7 +5801,8 @@ tcl::namespace::eval textblock {
}
append row $cell
}
lappend outlines $row
#lappend outlines $row
lset outlines $r $row
}
return [::join $outlines \n]
}
@ -5910,7 +5986,7 @@ tcl::namespace::eval textblock {
set table [[textblock::spantest] print]
set punks [a+ web-lawngreen][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a]
set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks]
set testblock [textblock::testblock 15 rainbow]
set testblock [textblock::testblock -size 15 rainbow]
set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks]
set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents]
}
@ -6206,9 +6282,11 @@ tcl::namespace::eval textblock {
set spec [string map [list <ftlist> $::textblock::frametypes] {
@id -id ::textblock::framedef
@cmd -name textblock::framedef\
-summary "Return frame graphical elements as a dictionary."\
-help "Return a dict of the elements that make up a frame border.
May return a subset of available elements based on memberglob values."
@leaders -min 0 -max 0
@opts
-joins -default "" -type list\
-help "List of join directions, any of: up down left right
or those combined with another frametype e.g left-heavy down-light."
@ -6216,7 +6294,7 @@ tcl::namespace::eval textblock {
-help "-boxonly true restricts results to the corner,vertical and horizontal box elements
It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj."
@values -min 1
@values -min 1 -max -1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary."
memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
@ -7619,7 +7697,7 @@ tcl::namespace::eval textblock {
} -help "Perform an action on the frame cache."
}
proc frame_cache {args} {
set argd [punk::args::get_by_id ::textblock::frame_cache $args]
set argd [punk::args::parse $args withid ::textblock::frame_cache]
set action [dict get $argd values action]
variable frame_cache
set all_values_dict [dict get $argd values]
@ -7664,7 +7742,7 @@ tcl::namespace::eval textblock {
endindex -default "" -type indexexpression
}
proc frame_cache_display {args} {
set argd [punk::args::get_by_id ::textblock::frame_cache_display $args]
set argd [punk::args::parse $args withid ::textblock::frame_cache_display]
variable frame_cache
lassign [dict values [dict get $argd values]] startidx endidx
set limit ""
@ -7769,11 +7847,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 +7875,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 +7934,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 +7982,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 ""
@ -7928,7 +8025,6 @@ tcl::namespace::eval textblock {
#never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame
if {[llength $args] != 1 && (!$opts_ok || $check_args)} {
#as frame is called a lot within table building - checking args can have a *big* impact on final performance.
#set argd [punk::args::get_by_id ::textblock::frame $args]
set argd [punk::args::parse $args withid ::textblock::frame]
set opts [dict get $argd opts]
set contents [dict get $argd values contents]
@ -8530,7 +8626,8 @@ tcl::namespace::eval textblock {
#puts "frame--->ansiwrap -rawansi [ansistring VIEW $opt_ansibase] $cache_inner"
if {$opt_ansibase ne ""} {
if {[punk::ansi::ta::detect $cache_inner]} {
set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner]
#set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner]
set cache_inner [punk::ansi::ansiwrap_raw $opt_ansibase "" "" $cache_inner]
} else {
set cache_inner "$opt_ansibase$cache_inner\x1b\[0m"
}
@ -8561,7 +8658,8 @@ tcl::namespace::eval textblock {
#JMN test
#assert - lhs, cache_inner, rhs non-ragged - so can use join_basic REVIEW
#set cache_body [textblock::join -- {*}$cache_bodyparts]
set cache_body [textblock::join_basic -- {*}$cache_bodyparts]
#set cache_body [textblock::join_basic -- {*}$cache_bodyparts]
set cache_body [textblock::join_basic_raw {*}$cache_bodyparts]
append fscached $cache_body
#append fs $body
@ -8622,7 +8720,8 @@ tcl::namespace::eval textblock {
set contents_has_ansi [punk::ansi::ta::detect $contents]
if {$opt_ansibase ne ""} {
if {$contents_has_ansi} {
set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents]
#set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents]
set contents [punk::ansi::ansiwrap_raw $opt_ansibase "" "" $contents]
} else {
set contents "$opt_ansibase$contents\x1b\[0m"
set contents_has_ansi 1

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

@ -181,16 +181,18 @@ set startdir [pwd]
# -------------------------------------------------------------------------------------
set bootsupport_module_paths [list]
set bootsupport_library_paths [list]
#we always create these lists in order of desired precedence.
# - this is the same order when adding to auto_path - but will need to be reversed when using tcl:tm::add
if {[file exists [file join $startdir src bootsupport]]} {
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order
lappend bootsupport_module_paths [file join $startdir src bootsupport modules]
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv]
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $startdir src bootsupport lib]
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv]
} else {
lappend bootsupport_module_paths [file join $startdir bootsupport modules]
lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv]
lappend bootsupport_library_paths [file join $startdir bootsupport lib]
lappend bootsupport_module_paths [file join $startdir bootsupport modules]
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv]
lappend bootsupport_library_paths [file join $startdir bootsupport lib]
}
set bootsupport_paths_exist 0
foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] {
@ -210,13 +212,13 @@ set sourcesupport_paths_exist 0
#(most?) Modules in src/modules etc should still be runnable directly in certain cases like this where we point to them.
if {[file tail $startdir] eq "src"} {
#todo - other src 'module' dirs..
foreach p [list $startdir/modules $startdir/modules_tcl$::tclmajorv $startdir/vendormodules $startdir/vendormodules_tcl$::tclmajorv] {
foreach p [list $startdir/modules_tcl$::tclmajorv $startdir/modules $startdir/vendormodules_tcl$::tclmajorv $startdir/vendormodules] {
if {[file exists $p]} {
lappend sourcesupport_module_paths $p
}
}
# -- -- --
foreach p [list $startdir/lib $startdir/lib_tcl$::tclmajorv $startdir/vendorlib $startdir/vendorlib_tcl$::tclmajorv] {
foreach p [list $startdir/lib_tcl$::tclmajorv $startdir/lib $startdir/vendorlib_tcl$::tclmajorv $startdir/vendorlib] {
if {[file exists $p]} {
lappend sourcesupport_library_paths $p
}
@ -273,16 +275,48 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
package forget $pkg
}
}
#tcl::tm::add {*}$original_tm_list {*}$bootsupport_module_paths {*}$sourcesupport_module_paths
#set ::auto_path [list {*}$original_auto_path {*}$bootsupport_library_paths {*}$sourcesupport_library_paths]
tcl::tm::add {*}$bootsupport_module_paths {*}$sourcesupport_module_paths
set ::auto_path [list {*}$bootsupport_library_paths {*}$sourcesupport_library_paths]
#Deliberately omit original_tm_list and original_auto_path
tcl::tm::add {*}[lreverse $bootsupport_module_paths] {*}[lreverse $sourcesupport_module_paths] ;#tm::add works like LIFO. sourcesupport_module_paths end up earliest in resulting tm list.
set ::auto_path [list {*}$sourcesupport_library_paths {*}$bootsupport_library_paths]
}
puts "----> auto_path $::auto_path"
puts "----> tcl::tm::list [tcl::tm::list]"
#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"
}
}
#--------------------------------------------------------
#package require Thread
puts "---->tcl_library [info library]"
puts "---->loaded [info loaded]"
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly.
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list
@ -297,6 +331,8 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
package require punk::lib
package require punk::args
package require punk::ansi
package require textblock
set package_paths_modified 1
@ -1218,14 +1254,19 @@ if {$::punkboot::command eq "check"} {
}
# -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
# - package path restore original module paths and auto_path entries to take effect in addition to bootsupport paths
# - Order such that bootsupport entries are always higher priority (if same version number - prefer bootsupport)
# - This must be done between the two "check" command sections
if {$package_paths_modified} {
set tm_list_now [tcl::tm::list]
foreach p $original_tm_list {
if {$p ni $tm_list_now} {
set tm_list_boot [tcl::tm::list]
tcl::tm::remove {*}$tm_list_boot
foreach p [lreverse $original_tm_list] {
if {$p ni $tm_list_boot} {
tcl::tm::add $p
}
}
foreach p [lreverse $tm_list_boot] {
tcl::tm::add $p
}
#set ::auto_path [list $bootsupport_lib {*}$original_auto_path]
lappend ::auto_path {*}$original_auto_path
}
@ -1333,11 +1374,13 @@ if {$::punkboot::command eq "info"} {
if {$::punkboot::command eq "shell"} {
puts stderr ">>>>>> loaded:[info loaded]"
package require punk
package require punk::repl
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell"
#todo - make procs vars etc from this file available?
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell."
repl::init
repl::start stdin
@ -1504,7 +1547,7 @@ if {$::punkboot::command eq "bootsupport"} {
proc modfile_sort {p1 p2} {
lassign [split [file rootname $p1] -] _ v1
lassign [split [file rootname $p1] -] _ v2
lassign [split [file rootname $p2] -] _ v2
package vcompare $v1 $v2
}
proc bootsupport_localupdate {projectroot} {
@ -1543,7 +1586,10 @@ if {$::punkboot::command eq "bootsupport"} {
set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]]
set srclocation [file join $projectroot $relpath $module_subpath]
#puts stdout "$relpath $modulematch $module_subpath $srclocation"
if {[string first - $modulematch]} {
#we must always glob using the dash - or we will match libraries that are suffixes of others
#bare lib.tm with no version is not valid.
if {[string first - $modulematch] != -1} {
#version or part thereof is specified.
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm]
} else {
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm]
@ -1566,6 +1612,7 @@ if {$::punkboot::command eq "bootsupport"} {
#review
set copy_files $pkgmatches
}
#if a file added manually to target dir - there will be no .punkcheck record - will be detected as changed
foreach cfile $copy_files {
set srcfile [file join $srclocation $cfile]
set tgtfile [file join $targetroot $module_subpath $cfile]
@ -1574,6 +1621,8 @@ if {$::punkboot::command eq "bootsupport"} {
$boot_event targetset_init INSTALL $tgtfile
$boot_event targetset_addsource $srcfile
#----------
#
#puts "bootsuport target $tgtfile record size: [dict size [$boot_event targetset_last_complete]]"
if {\
[llength [dict get [$boot_event targetset_source_changes] changed]]\
|| [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\

37
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm

@ -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

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

@ -46,6 +46,7 @@ set bootsupport_modules [list\
modules punkcheck\
modules punkcheck::cli\
modules punk::aliascore\
modules punk::ansi::colourmap\
modules punk::ansi\
modules punk::assertion\
modules punk::args\
@ -61,6 +62,7 @@ set bootsupport_modules [list\
modules punk::fileline\
modules punk::docgen\
modules punk::lib\
modules punk::libunknown\
modules punk::mix\
modules punk::mix::base\
modules punk::mix::cli\

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

File diff suppressed because it is too large Load Diff

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

@ -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

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

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,966 @@
# -*- 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}]
#*** !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]

6274
src/vfs/_vfscommon.vfs/modules/punk/args-0.1.8.tm → src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm

File diff suppressed because it is too large Load Diff

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

@ -449,7 +449,7 @@ tcl::namespace::eval punk::config {
Accepts globs eg XDG*"
@leaders -min 1 -max 1
#todo - load more whichconfig choices?
whichconfig -type string -choices {config startup-configuration running-configuration}
whichconfig -type any -choices {config startup-configuration running-configuration}
@values -min 0 -max -1
globkey -type string -default * -optional 1 -multiple 1
}]
@ -495,7 +495,7 @@ tcl::namespace::eval punk::config {
@cmd -name punk::config::configure -help\
"Get/set configuration values from a config"
@leaders -min 1 -max 1
whichconfig -type string -choices {defaults startup-configuration running-configuration}
whichconfig -type any -choices {defaults startup-configuration running-configuration}
@values -min 0 -max 2
key -type string -optional 1
newvalue -optional 1

21
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm

@ -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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm

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

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

@ -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 [llength $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 [llength $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
@ -695,14 +741,15 @@ namespace eval punk::lib {
proc lswap {lvar a z} {
upvar $lvar l
if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} {
set len [llength $l]
if {[lindex_resolve_basic $len $a] < 0 || [lindex_resolve_basic $len $z] < 0} {
#lindex_resolve_basic returns only -1 if out of range
#if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred
#(e.g using: lswap mylist end-2 end on a two element list)
#on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report
#use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned)
set a_index [lindex_resolve $l $a]
set a_index [lindex_resolve $len $a]
set a_msg ""
switch -- $a_index {
-2 {
@ -712,7 +759,7 @@ namespace eval punk::lib {
set a_msg "1st supplied index $a is below the lower bound for the list (0)"
}
}
set z_index [lindex_resolve $l $z]
set z_index [lindex_resolve $len $z]
set z_msg ""
switch -- $z_index {
-2 {
@ -1100,7 +1147,7 @@ namespace eval punk::lib {
- then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator.
e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1
Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent
The second level segement in each pattern switches to a dict operation to retrieve the value by key.
The second level segment in each pattern switches to a dict operation to retrieve the value by key.
When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level.
}
}]
@ -1137,11 +1184,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 +1222,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"
@ -1465,7 +1515,7 @@ namespace eval punk::lib {
if {![regexp $re_idxdashidx $p _match a b]} {
error "unrecognised pattern $p"
}
set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high
set lower_resolve [punk::lib::lindex_resolve [llength $dval] $a] ;#-2 for too low, -1 for too high
#keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds
if {${lower_resolve} == -2} {
##x
@ -1478,7 +1528,7 @@ namespace eval punk::lib {
} else {
set lower $lower_resolve
}
set upper [punk::lib::lindex_resolve $dval $b]
set upper [punk::lib::lindex_resolve [llength $dval] $b]
if {$upper == -3} {
##x
#upper bound is below list range -
@ -1831,7 +1881,8 @@ namespace eval punk::lib {
if {$last_hidekey} {
append result \n
}
append result [textblock::join_basic -- $kblock $sblock $vblock] \n
#append result [textblock::join_basic -- $kblock $sblock $vblock] \n
append result [textblock::join_basic_raw $kblock $sblock $vblock] \n
}
set last_hidekey $hidekey
incr kidx
@ -1880,6 +1931,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 +1952,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 +1975,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 +1992,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]
@ -2158,35 +2242,75 @@ namespace eval punk::lib {
}
}
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side
proc lindex_resolve {list index} {
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bounds on upper vs lower side
#REVIEW: This shouldn't really need the list itself - just the length would suffice
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 or string length."\
-help\
"Resolve an index which may be of the forms accepted by Tcl list or string commands such as end-2 or 2+2
to the actual integer index for the supplied list/string length, or to a negative value below -1 indicating
whether the index was below or above the range of possible indices for the length supplied.
Users may define procs which accept a list/string 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/string.
Otherwise it will return an integer corresponding to the position in the data.
This is in stark contrast to Tcl list/string 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/string (datalength 0), 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
datalength -type integer
index -type indexexpression
}
proc lindex_resolve {len index} {
#*** !doctools
#[call [fun lindex_resolve] [arg list] [arg index]]
#[para]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
#[para]Users may define procs which accept a list index and wish to accept the forms understood by Tcl.
#[call [fun lindex_resolve] [arg len] [arg index]]
#[para]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/string length
#[para]Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl.
#[para]This means the proc may be called with something like $x+2 end-$y etc
#[para]Sometimes the actual integer index is desired.
#[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks.
#[para]lindex_resolve will parse the index expression and return:
#[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0)
#[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] 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/string
#[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 ???
#}
if {![string is integer -strict $len]} {
#<0 ?
error "lindex_resolve len must be an integer"
}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
if {$index < 0} {
return -3
} elseif {$index >= [llength $list]} {
} elseif {$index >= $len} {
return -2
} else {
#integer may still have + sign - normalize with expr
@ -2203,7 +2327,7 @@ namespace eval punk::lib {
}
} else {
#index is 'end'
set index [expr {[llength $list]-1}]
set index [expr {$len-1}]
if {$index < 0} {
#special case - 'end' with empty list - treat end like a positive number out of bounds
return -2
@ -2212,7 +2336,7 @@ namespace eval punk::lib {
}
}
if {$offset == 0} {
set index [expr {[llength $list]-1}]
set index [expr {$len-1}]
if {$index < 0} {
return -2 ;#special case as above
} else {
@ -2220,7 +2344,7 @@ namespace eval punk::lib {
}
} else {
#by now, if op = + then offset = 0 so we only need to handle the minus case
set index [expr {([llength $list]-1) - $offset}]
set index [expr {($len-1) - $offset}]
}
if {$index < 0} {
return -3
@ -2245,33 +2369,32 @@ namespace eval punk::lib {
}
if {$index < 0} {
return -3
} elseif {$index >= [llength $list]} {
} elseif {$index >= $len} {
return -2
}
return $index
}
}
}
proc lindex_resolve_basic {list index} {
proc lindex_resolve_basic {len index} {
#*** !doctools
#[call [fun lindex_resolve_basic] [arg list] [arg index]]
#[call [fun lindex_resolve_basic] [arg len] [arg index]]
#[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2)
#[para] returns -1 for out of range at either end, or a valid integer index
#[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound
#[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command
#[para] This is only likely to be faster than average over lindex_resolve for small lists and for Tcl which has the builtin lseq command
#[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1
#[para] For pure integer indices the performance should be equivalent
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+
# - which
#for {set i 0} {$i < [llength $list]} {incr i} {
# lappend indices $i
#}
if {![string is integer -strict $len]} {
error "lindex_resolve_basic len must be an integer"
}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
#avoid even the lseq overhead when the index is simple
if {$index < 0 || ($index >= [llength $list])} {
if {$index < 0 || ($index >= $len)} {
#even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method.
return -1
} else {
@ -2279,13 +2402,15 @@ namespace eval punk::lib {
return [expr {$index}]
}
}
if {[llength $list]} {
set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback.
#if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?)
if {$len > 0} {
#For large len - this is a wasteful allocation if no true lseq available in Tcl version.
#lseq produces an 'arithseries' object which we can index into without allocating an entire list (REVIEW)
set testlist [punk::lib::range 0 [expr {$len-1}]] ;# uses lseq if available, has fallback.
} else {
set indices [list]
set testlist [list]
#we want to call 'lindex' even in this case - to get the appropriate error message
}
set idx [lindex $indices $index]
set idx [lindex $testlist $index]
if {$idx eq ""} {
#we have no way to determine if out of bounds is at lower vs upper end
return -1
@ -2304,6 +2429,81 @@ namespace eval punk::lib {
}
}
proc string_splitbefore {str index} {
if {![string is integer -strict $index]} {
set index [punk::lib::lindex_resolve [string length $str] $index]
switch -- $index {
-2 {
return [list $str ""]
}
-3 {
return [list "" $str]
}
}
}
return [list [string range $str 0 $index-1] [string range $str $index end]]
#scan %s stops at whitespace - not useful here.
#scan $s %${p}s%s
}
proc string_splitbefore_indices {str args} {
set parts [list $str]
set sizes [list [string length $str]]
set s 0
foreach index $args {
if {![string is integer -strict $index]} {
set index [punk::lib::lindex_resolve [string length $str] $index]
switch -- $index {
-2 {
if {[lindex $sizes end] != 0} {
ledit parts end end [lindex $parts end] {}
ledit sizes end end [lindex $sizes end] 0
}
continue
}
-3 {
if {[lindex $sizes 0] != 0} {
ledit parts 0 0 {} [lindex $parts 0]
ledit sizes 0 0 0 [lindex $sizes 0]
}
continue
}
}
}
if {$index <= 0} {
if {[lindex $sizes 0] != 0} {
ledit parts 0 0 {} [lindex $parts 0]
ledit sizes 0 0 0 [lindex $sizes 0]
}
continue
}
if {$index >= [string length $str]} {
if {[lindex $sizes end] != 0} {
ledit parts end end [lindex $parts end] {}
ledit sizes end end [lindex $sizes end] 0
}
continue
}
set i -1
set a 0
foreach sz $sizes {
incr i
if {$a + $sz > $index} {
set p [lindex $parts $i]
#puts "a:$a index:$index"
if {$a == $index} {
break
}
ledit parts $i $i [string range $p 0 [expr {$index -$a -1}]] [string range $p $index-$a end]
ledit sizes $i $i [expr {$index - $a}] [expr {($a + $sz)-$index}]
break
}
incr a $sz
}
#puts "->parts:$parts"
#puts "->sizes:$sizes"
}
return $parts
}
proc K {x y} {return $x}
#*** !doctools
@ -3133,8 +3333,7 @@ namespace eval punk::lib {
#Each resulting line should have a reset of some type at start and a pure-reset at end to stop
#see if we can find an ST sequence that most terminals will not display for marking sections?
if {$opt_ansireplays} {
#package require punk::ansi
<require_punk_ansi>
<require_punk_ansi> ;#package require punk::ansi
if {$opt_ansiresets} {
set RST "\x1b\[0m"
} else {

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

File diff suppressed because it is too large Load Diff

22
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm

@ -53,11 +53,6 @@ namespace eval punk::mix::commandset::loadedlib {
#REVIEW - this doesn't result in full scans
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything
if {[catch {package require natsort}]} {
set has_natsort 0
} else {
set has_natsort 1
}
set packages [package names]
set matches [list]
foreach search $searchstrings {
@ -85,11 +80,7 @@ namespace eval punk::mix::commandset::loadedlib {
# set versions $v
#}
}
if {$has_natsort} {
set versions [natsort::sort $versions]
} else {
set versions [lsort $versions]
}
set versions [lsort -command {package vcompare} $versions]
if {$opt_highlight} {
set v [package provide $m]
if {$v ne ""} {
@ -188,11 +179,6 @@ namespace eval punk::mix::commandset::loadedlib {
}
proc info {libname} {
if {[catch {package require natsort}]} {
set has_natsort 0
} else {
set has_natsort 1
}
catch {package require $libname 1-0} ;#ensure pkg system has loaded/searched - using unsatisfiable version range
set pkgsknown [package names]
if {[set posn [lsearch $pkgsknown $libname]] >= 0} {
@ -201,11 +187,7 @@ namespace eval punk::mix::commandset::loadedlib {
puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path"
}
set versions [package versions [lindex $libname 0]]
if {$has_natsort} {
set versions [natsort::sort $versions]
} else {
set versions [lsort $versions]
}
set versions [lsort -command {package vcompare} $versions]
if {![llength $versions]} {
puts stderr "No version numbers found for library/module $libname"
return false

9
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm

@ -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]

40
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm

@ -592,10 +592,23 @@ namespace eval punk::mix::commandset::project {
namespace export *
namespace path [namespace parent]
punk::args::define {
@id -id ::punk::mix::commandset::project::collection::_default
@cmd -name "punk::mix::commandset::project::collection::_default"\
-summary\
"List projects under fossil managment."\
-help\
"List projects under fossil management, showing fossil db location and number of checkouts"
@values -min 0 -max -1
glob -type string -multiple 1 -default *
}
#e.g imported as 'projects'
proc _default {{glob {}} args} {
proc _default {args} {
set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default]
set globlist [dict get $argd values glob]
#*** !doctools
#[call [fun _default] [arg glob] [opt {option value...}]]
#[call [fun _default] [arg glob...]]
#[para]List projects under fossil management, showing fossil db location and number of checkouts
#[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied
#[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s
@ -604,7 +617,7 @@ namespace eval punk::mix::commandset::project {
#[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection
#[para]Will result in the command being available as <ensemblecommand> projects
package require overtype
set db_projects [lib::get_projects $glob]
set db_projects [lib::get_projects {*}$globlist]
set col1items [lsearch -all -inline -index 0 -subindices $db_projects *]
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *]
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *]
@ -1012,12 +1025,21 @@ namespace eval punk::mix::commandset::project {
#consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run
return [string cat % $tagname %]
}
#get project info only by opening the central confg-db
#(will not have proper project-name etc)
proc get_projects {{globlist {}} args} {
if {![llength $globlist]} {
set globlist [list *]
}
punk::args::define {
@id -id ::punk::mix::commandset::project::lib::get_projects
@cmd -name punk::mix::commandset::project::lib::get_projects\
-summary\
"List projects referred to by central fossil config-db."\
-help\
"Get project info only by opening the central fossil config-db
(will not have proper project-name etc)"
@values -min 0 -max -1
glob -type string -multiple 1 -default * -optional 1
}
proc get_projects {args} {
set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects]
set globlist [dict get $argd values glob]
set fossil_prog [auto_execok fossil]
set configdb [punk::repo::fossil_get_configdb]

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

@ -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]

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

@ -177,10 +177,10 @@ tcl::namespace::eval punk::ns {
} else {
set fq_nspath $nspath
}
if {[catch {nseval_ifexists $fq_nspath {}}]} {
return 0
} else {
if {[nseval_ifexists $fq_nspath {::string cat ok}] eq "ok"} {
return 1
} else {
return 0
}
}
@ -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]
@ -757,13 +758,20 @@ tcl::namespace::eval punk::ns {
}
set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370]
if {[llength $ansinames]} {
return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type][punk::ansi::a]"
return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type]\x1b\[0m"
} else {
return [dict get $marks $type]
}
}
#REVIEW - ansi codes can be *very* confusing to the user when trying to handle lists etc..
punk::args::define {
@id -id ::punk::ns::get_nslist
@cmd -name punk::ns::get_nslist
@opts
-match -default ""
-nsdict -type dict -default {}
}
proc get_nslist {args} {
set known_types [list children commands exported imported aliases procs ensembles ooclasses ooobjects ooprivateobjects ooprivateclasses native coroutines interps zlibstreams]
set defaults [dict create\
@ -774,6 +782,9 @@ tcl::namespace::eval punk::ns {
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- ---
set fq_glob [dict get $opts -match]
if {$fq_glob eq ""} {
set fq_glob [uplevel 1 nsthis]::*
}
set requested_types [dict get $opts -types]
set opt_nsdict [dict get $opts -nsdict]
@ -834,7 +845,7 @@ tcl::namespace::eval punk::ns {
set zlibstreams [list]
set usageinfo [list]
if {$opt_nsdict eq ""} {
if {![dict size $opt_nsdict]} {
set nsmatches [get_ns_dicts $fq_glob -allbelow 0]
set itemcount 0
set matches_with_results [list]
@ -866,6 +877,8 @@ tcl::namespace::eval punk::ns {
}
if {"commands" in $types} {
set commands [dict get $contents commands]
}
set usageinfo [dict get $contents usageinfo]
foreach t $types {
switch -- $t {
exported {
@ -909,8 +922,6 @@ tcl::namespace::eval punk::ns {
}
}
}
set usageinfo [dict get $contents usageinfo]
}
set numchildren [llength $children]
if {$numchildren} {
@ -1067,7 +1078,7 @@ tcl::namespace::eval punk::ns {
} else {
}
if {$cmd in $imported} {
set prefix [overtype::right $prefix "-[a+ yellow bold]I[a+]"]
set prefix [overtype::right $prefix "-[a+ yellow bold]I[a]"]
}
}
if {$cmd in $usageinfo} {
@ -1075,7 +1086,8 @@ tcl::namespace::eval punk::ns {
} else {
set u ""
}
set cmd$i "${prefix} $c$cmd_display$u"
#set cmd$i "${prefix} $c$cmd_display$u"
set cmd$i "${prefix} [punk::ansi::ansiwrap -rawansi $c $cmd_display]$u"
#set c$i $c
set c$i ""
lappend seencmds $cmd
@ -1146,7 +1158,11 @@ tcl::namespace::eval punk::ns {
the child namespaces and commands within
the namespace(s) matched by glob."
@opts
-nspathcommands -type boolean -default 0
-nspathcommands -type boolean -default 0 -help\
"When a namespace has entries configured in 'namespace path', the default result for nslist
will display just a basic note: 'Also resolving cmds in namespace paths: <namespaces>'.
If -nspathcommands is true, it will also display subtables showing the commands resolvable
via any such listed namespaces."
-types
@values -min 0 -max -1
glob -multiple 1 -optional 1 -default "*"
@ -1205,9 +1221,9 @@ tcl::namespace::eval punk::ns {
if {[dict size [dict get $nsdict namespacepath]]} {
set path_text ""
if {!$opt_nspathcommands} {
append path_text \n " also resolving cmds in namespace paths: [dict keys [dict get $nsdict namespacepath]]"
append path_text \n " Also resolving cmds in namespace paths: [dict keys [dict get $nsdict namespacepath]]"
} else {
append path_text \n " also resolving cmds in namespace paths:"
append path_text \n " Also resolving cmds in namespace paths:"
set nspathdict [dict get $nsdict namespacepath]
if {!$has_textblock} {
dict for {k v} $nspathdict {
@ -1216,8 +1232,14 @@ tcl::namespace::eval punk::ns {
append path_text \n " cmds: $cmds"
}
} else {
#todo - change to display in column order to be same as main command listing
dict for {k v} $nspathdict {
set t [textblock::list_as_table -title $k -columns 6 [lsort [dict get $v commands]]]
set pathcommands [dict get $v commands]
set columns 6
if {[llength $pathcommands] < 6} {
set columns [llength $v]
}
set t [textblock::list_as_table -title $k -columns $columns [lsort $pathcommands]]
append path_text \n $t
}
}
@ -1423,7 +1445,7 @@ tcl::namespace::eval punk::ns {
}
}
return $matches
}]
}]]
} else {
lappend matched {*}[tcl::namespace::eval $location [list ::info commands [nsjoin ${location} $p]]]
@ -2397,14 +2419,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 +2444,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 +2535,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 +2552,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 +2618,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 +2649,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 +2679,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 +2706,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 +2971,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 +3087,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 +3141,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 +3197,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 +3677,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
}
@ -3620,6 +3703,21 @@ tcl::namespace::eval punk::ns {
comment inserted to display information such as the
namespace origin. Such a comment begins with #corp#."
@opts
-syntax -default basic -choices {none basic}\
-choicelabels {
none\
" Plain text output"
basic\
" Comment and bracket highlights.
This is a basic colourizer - not
a full Tcl syntax highlighter."
}\
-help\
"Type of syntax highlighting on result.
Note that -syntax none will always return a proper Tcl
List: proc <name> <arglist> <body>
- but a syntax highlighter may return a string that
is not a Tcl list."
@values -min 1 -max -1
commandname -help\
"May be either the fully qualified path for the command,
@ -3629,6 +3727,7 @@ tcl::namespace::eval punk::ns {
proc corp {args} {
set argd [punk::args::parse $args withid ::punk::ns::corp]
set path [dict get $argd values commandname]
set syntax [dict get $argd opts -syntax]
#thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp
#Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name)
if {[info exists punk::console::tabwidth]} {
@ -3713,6 +3812,18 @@ tcl::namespace::eval punk::ns {
lappend argl $a
}
#list proc [nsjoin ${targetns} $name] $argl $body
switch -- $syntax {
basic {
#rudimentary colourising only
set argl [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl]
set body [punk::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one.
set body [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $body]
set body [punk::grepstr -return all -highlight tk-orange {\[|\]} $body]
#ansi colourised items in list format may not always have desired string representation (list escaping can occur)
#return as a string - which may not be a proper Tcl list!
return "proc $resolved {$argl} {\n$body\n}"
}
}
list proc $resolved $argl $body
}
@ -3799,13 +3910,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 +4034,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 +4074,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}

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

@ -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 {} {
@ -194,7 +194,7 @@ tcl::namespace::eval punk::packagepreference {
if {!$is_exact && [llength $vwant] <= 1 } {
#required version unspecified - or specified singularly
set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg]
if {[llength $available_versions] > 1} {
if {[llength $available_versions] >= 1} {
# ---------------------------------------------------------------
#An attempt to detect dll/so loaded and try to load same version
#dll/so files are often named with version numbers that don't contain dots or a version number at all
@ -202,9 +202,11 @@ tcl::namespace::eval punk::packagepreference {
set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg]
if {[llength $pkgloadedinfo]} {
puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available"
lassign $pkgloadedinfo path name
set lcpath [string tolower $path]
if {[llength $available_versions] > 1} {
puts stderr "--> pkg $pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and [llength $available_versions] versions available"
}
lassign $pkgloadedinfo loaded_path name
set lc_loadedpath [string tolower $loaded_path]
#first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement.
set lcpath_to_version [dict create]
foreach av $available_versions {
@ -212,17 +214,19 @@ tcl::namespace::eval punk::packagepreference {
#ifneeded script not always a valid tcl list
if {![catch {llength $scr} scrlen]} {
if {$scrlen == 3 && [lindex $scr 0] eq "load" && [string match -nocase [lindex $scr 2] $pkg]} {
#a basic 'load <path> <pkg>' statement
dict set lcpath_to_version [string tolower [lindex $scr 1]] $av
}
}
}
if {[dict exists $lcpath_to_version $lcpath]} {
set lversion [dict get $lcpath_to_version $lcpath]
if {[dict exists $lcpath_to_version $lc_loadedpath]} {
set lversion [dict get $lcpath_to_version $lc_loadedpath]
} else {
#fallback to a best effort guess based on the path
set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg]
set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $loaded_path $pkg]
}
#puts "====lcpath_to_version: $lcpath_to_version"
if {$lversion ne ""} {
#name matches pkg
#hack for known dll version mismatch
@ -232,24 +236,103 @@ tcl::namespace::eval punk::packagepreference {
if {[llength $vwant] == 1} {
#todo - still check vsatisfies - report a conflict? review
}
return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
#return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
try {
set result [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
} trap {} {emsg eopts} {
#REVIEW - this occurred in punkmagic (rebuild of tclmagic) - probably due to multiple versions of registry
#under different auto_path folders - and mal-ordering in punk::libunknown's tclPkgUnknown
#May be obsolete.. issue still not clear
#A hack for 'couldn't open "<path.dll>": permission denied'
#This happens for example with the tcl9registry13.dll when loading from zipfs - but not in all systems, and not for all dlls.
#exact cause unknown.
#e.g
#%package ifneeded registry 1.3.7
#- load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry
#%load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry
#couldn't open "C:/Users/sleek/AppData/Local/Temp/TCL00003cf8/tcl9registry13.dll": permission denied
#a subsequent load of the path used in the error message works.
#if {[string match "couldn't open \"*\": permission denied" $emsg]} {}
if {[regexp {couldn't open "(.*)":.*permission denied.*} $emsg _ newpath]} {
#Since this is a hack that shouldn't be required - be noisy about it.
puts stderr ">>> $emsg"
puts stderr "punk::packagepreference::require hack: Re-trying load of $pkg with path: $newpath"
return [load $newpath $pkg]
} else {
#puts stderr "??? $emsg"
#dunno - re-raise
return -options $eopts $emsg
}
}
return $result
}
#else puts stderr "> no version determined for pkg: $pkg loaded_path: $loaded_path"
}
}
}
# ---------------------------------------------------------------
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
#j2
$COMMANDSTACKNEXT require punk::args::$dp
}
}
#---------------------------------------------------------------
return $require_result
}
default {
return [$COMMANDSTACKNEXT {*}$args]

6
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm

@ -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

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

@ -373,6 +373,7 @@ tcl::namespace::eval punk::pipe::lib {
if {$end_var_posn > 0} {
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead.
#lassign [scan $token %${end_var_posn}s%s] var spec
#lassign [punk::lib::string_splitbefore $token $end_var_posn] var spec
set var [string range $token 0 $end_var_posn-1]
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec
} else {
@ -430,7 +431,7 @@ tcl::namespace::eval punk::pipe::lib {
}
#if {[string length $token]} {
# #lappend varlist [splitstrposn $token $end_var_posn]
# #lappend varlist [punk::lib::string_splitbefore $token $end_var_posn]
# set var $token
# set spec ""
# if {$end_var_posn > 0} {

2
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm

@ -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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm

@ -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

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

@ -243,14 +243,10 @@ namespace eval punkcheck {
}
method get_targets_exist {} {
set punkcheck_folder [file dirname [$o_installer get_checkfile]]
#puts stdout "### punkcheck glob -dir $punkcheck_folder -tails {*}$o_targets"
#targets can be paths such as punk/mix/commandset/module-0.1.0.tm - glob can search levels below supplied -dir
set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets]
#set existing [list]
#foreach t $o_targets {
# if {[file exists [file join $punkcheck_folder $t]]} {
# lappend existing $t
# }
#}
return $existing
}
method end {} {

3329
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.tm

File diff suppressed because it is too large Load Diff

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

@ -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
@ -154,7 +174,6 @@ tcl::namespace::eval textblock {
}
}
proc use_hash {args} {
#set argd [punk::args::get_by_id ::textblock::use_hash $args]
set argd [punk::args::parse $args withid ::textblock::use_hash]
variable use_hash
if {![dict exists $argd received hash_algorithm]} {
@ -2294,7 +2313,8 @@ tcl::namespace::eval textblock {
#JMN
#spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic
set spanned_frame [textblock::join_basic -- {*}$spanned_parts]
#set spanned_frame [textblock::join_basic -- {*}$spanned_parts]
set spanned_frame [textblock::join_basic_raw {*}$spanned_parts]
if {$spans_to_rhs} {
if {$cidx == 0} {
@ -2363,7 +2383,8 @@ tcl::namespace::eval textblock {
} else {
#this_span == 1
set spanned_frame [textblock::join_basic -- $header_cell_startspan]
#set spanned_frame [textblock::join_basic -- $header_cell_startspan]
set spanned_frame [textblock::join_basic_raw $header_cell_startspan]
}
@ -3992,7 +4013,8 @@ tcl::namespace::eval textblock {
set body_build ""
} else {
#body blocks should not be ragged - so can use join_basic
set body_build [textblock::join_basic -- {*}$body_blocks]
#set body_build [textblock::join_basic -- {*}$body_blocks]
set body_build [textblock::join_basic_raw {*}$body_blocks]
}
if {$headerheight > 0} {
set table [tcl::string::cat $header_build \n $body_build]
@ -4149,7 +4171,6 @@ tcl::namespace::eval textblock {
proc periodic {args} {
#For an impressive interactive terminal app (javascript)
# see: https://github.com/spirometaxas/periodic-table-cli
#set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts]
set opts [dict get [punk::args::parse $args withid ::textblock::periodic] opts]
set opt_return [tcl::dict::get $opts -return]
if {[tcl::dict::get $opts -forcecolour]} {
@ -4446,7 +4467,7 @@ tcl::namespace::eval textblock {
proc list_as_table {args} {
set FRAMETYPES [textblock::frametypes]
set argd [punk::args::get_by_id ::textblock::list_as_table $args]
set argd [punk::args::parse $args withid ::textblock::list_as_table]
set opts [dict get $argd opts]
set received [dict get $argd received]
@ -4644,7 +4665,8 @@ tcl::namespace::eval textblock {
if {[tcl::string::last \n $charblock] >= 0} {
if {$blockwidth > 1} {
#set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks )
set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]]
#set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]]
set row [textblock::join_basic_raw {*}[lrepeat $blockwidth $charblock]]
} else {
set row $charblock
}
@ -4694,7 +4716,7 @@ tcl::namespace::eval textblock {
}
proc testblock {args} {
set argd [punk::args::get_by_id ::textblock::testblock $args]
set argd [punk::args::parse $args withid ::textblock::testblock]
set colour [dict get $argd values colour]
set size [dict get $argd opts -size]
@ -4762,7 +4784,8 @@ tcl::namespace::eval textblock {
if {"noreset" in $colour} {
return [textblock::join_basic -ansiresets 0 -- {*}$clist]
} else {
return [textblock::join_basic -- {*}$clist]
#return [textblock::join_basic -- {*}$clist]
return [textblock::join_basic_raw {*}$clist]
}
} elseif {"rainbow" in $colour} {
#direction must be horizontal
@ -5019,19 +5042,20 @@ tcl::namespace::eval textblock {
-width ""\
-overflow 0\
-within_ansi 0\
-return block\
]
#known_samewidth of empty string means we don't know either way, 0 is definitely 'ragged', 1 is definitely homogenous
#review!?
#-within_ansi means after a leading ansi code when doing left pad on all but last line
#-within_ansi means before a trailing ansi code when doing right pad on all but last line
set usage "pad block ?-padchar <sp>|<character>? ?-which right|left|centre? ?-known_hasansi \"\"|<bool>? ?-known_blockwidth \"\"|<int>? ?-width auto|<int>? ?-within_ansi 1|0?"
foreach {k v} $args {
switch -- $k {
-padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi {
-padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi - -return {
tcl::dict::set opts $k $v
}
default {
set usage "pad block ?-padchar <sp>|<character>? ?-which right|left|centre? ?-known_hasansi \"\"|<bool>? ?-known_blockwidth \"\"|<int>? ?-width auto|<int>? ?-within_ansi 1|0? ?-return block|list?"
error "textblock::pad unrecognised option '$k'. Usage: $usage"
}
}
@ -5177,25 +5201,34 @@ tcl::namespace::eval textblock {
set line_len 0
set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad
foreach {pt ansi} $parts {
if {$pt ne ""} {
set has_nl [expr {[tcl::string::last \n $pt]>=0}]
if {$has_nl} {
if {$pt eq ""} {
#we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes
lappend line_chunks ""
} elseif {[tcl::string::last \n $pt]==-1} {
lappend line_chunks $pt
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
incr line_len [punk::char::grapheme_width_cached $pt] ;#memleak - REVIEW
}
} else {
#set has_nl [expr {[tcl::string::last \n $pt]>=0}]
#if {$has_nl} {
set pt [tcl::string::map [list \r\n \n] $pt]
set partlines [split $pt \n]
} else {
set partlines [list $pt]
}
set last [expr {[llength $partlines]-1}]
set p 0
foreach pl $partlines {
lappend line_chunks $pl
#} else {
# set partlines [list $pt]
#}
#set last [expr {[llength $partlines]-1}]
#set p -1
foreach pl [lrange $partlines 0 end-1] {
#incr p
lappend line_chunks $pl ;#we need to lappend because there can already be some pt and ansi entries for the current line from previous {pt ansi} values where pt had no newline.
#incr line_len [punk::char::ansifreestring_width $pl]
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
}
if {$p != $last} {
#if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
# incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
#}
#do padding
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
set missing [expr {$width - $line_len}]
} else {
set missing [expr {$width - $datawidth}]
@ -5258,15 +5291,20 @@ tcl::namespace::eval textblock {
set line_len 0
incr lnum
}
incr p
#deal with last part zzz of xxx\nyyy\nzzz - not yet a complete line
set pl [lindex $partlines end]
lappend line_chunks $pl ;#we need to lappend because there can already be some pt and ansi entries for the current line from previous {pt ansi} values where pt had no newline.
if {$pl ne "" && ($known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq "")} {
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
}
} else {
#we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes
lappend line_chunks ""
}
#don't let trailing empty ansi affect the line_chunks length
if {$ansi ne ""} {
lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content?
lappend line_chunks $ansi ;#don't update line_len
#- review - ansi codes with visible content?
#- There shouldn't be any, even though for example some terminals display PM content
#e.g OSC 8 is ok as it has the uri 'inside' the ansi sequence, but that's ok because the displayable part is outside and is one of our pt values from split_codes.
}
}
#pad last line
@ -5325,7 +5363,11 @@ tcl::namespace::eval textblock {
}
}
lappend lines [::join $line_chunks ""]
if {[tcl::dict::get $opts -return] eq "block"} {
return [::join $lines \n]
} else {
return $lines
}
}
#left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single
@ -5566,7 +5608,7 @@ tcl::namespace::eval textblock {
#join without regard to each line length in a block (no padding added to make each block uniform)
proc ::textblock::join_basic {args} {
set argd [punk::args::get_by_id ::textblock::join_basic $args]
set argd [punk::args::parse $args withid ::textblock::join_basic]
set ansiresets [tcl::dict::get $argd opts -ansiresets]
set blocks [tcl::dict::get $argd values blocks]
@ -5602,6 +5644,33 @@ tcl::namespace::eval textblock {
}
return [::join $outlines \n]
}
proc ::textblock::join_basic_raw {args} {
#no options. -*, -- are legimate blocks
set blocklists [lrepeat [llength $args] ""]
set blocklengths [lrepeat [expr {[llength $args]+1}] 0] ;#add 1 to ensure never empty - used only for rowcount max calc
set i -1
foreach b $args {
incr i
if {[punk::ansi::ta::detect $b]} {
#-ansireplays 1 quite expensive e.g 7ms in 2024
set blines [punk::lib::lines_as_list -ansireplays 1 -ansiresets auto -- $b]
} else {
set blines [split $b \n]
}
lset blocklengths $i [llength $blines]
lset blocklists $i $blines
}
set rowcount [tcl::mathfunc::max {*}$blocklengths]
set outlines [lrepeat $rowcount ""]
for {set r 0} {$r < $rowcount} {incr r} {
set row ""
foreach blines $blocklists {
append row [lindex $blines $r]
}
lset outlines $r $row
}
return [::join $outlines \n]
}
proc ::textblock::join_basic2 {args} {
#@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width.
# Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
@ -5686,9 +5755,12 @@ tcl::namespace::eval textblock {
}
set idx 0
set blocklists [list]
#set blocklists [list]
set blocklists [lrepeat [llength $blocks] ""]
set rowcount 0
set bidx -1
foreach b $blocks {
incr bidx
#we need the width of a rendered block for per-row renderline calls or padding
#we may as well use widthinfo to also determine raggedness state to pass on to pad function
#set bwidth [width $b]
@ -5705,18 +5777,21 @@ tcl::namespace::eval textblock {
if {[punk::ansi::ta::detect $b]} {
# - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?)
set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n]
set bl [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
#set blines [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
set blines [textblock::pad $replay_block -return lines -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "]
} else {
#each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi
set bl [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
#set blines [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
set blines [textblock::pad $b -return lines -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "]
}
set rowcount [expr {max($rowcount,[llength $bl])}]
lappend blocklists $bl
set rowcount [expr {max($rowcount,[llength $blines])}]
#lappend blocklists $bl
lset blocklists $bidx $blines
set width($idx) $bwidth
incr idx
}
set outlines [list]
set outlines [lrepeat $rowcount ""]
for {set r 0} {$r < $rowcount} {incr r} {
set row ""
for {set c 0} {$c < [llength $blocklists]} {incr c} {
@ -5726,7 +5801,8 @@ tcl::namespace::eval textblock {
}
append row $cell
}
lappend outlines $row
#lappend outlines $row
lset outlines $r $row
}
return [::join $outlines \n]
}
@ -5910,7 +5986,7 @@ tcl::namespace::eval textblock {
set table [[textblock::spantest] print]
set punks [a+ web-lawngreen][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a]
set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks]
set testblock [textblock::testblock 15 rainbow]
set testblock [textblock::testblock -size 15 rainbow]
set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks]
set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents]
}
@ -6206,9 +6282,11 @@ tcl::namespace::eval textblock {
set spec [string map [list <ftlist> $::textblock::frametypes] {
@id -id ::textblock::framedef
@cmd -name textblock::framedef\
-summary "Return frame graphical elements as a dictionary."\
-help "Return a dict of the elements that make up a frame border.
May return a subset of available elements based on memberglob values."
@leaders -min 0 -max 0
@opts
-joins -default "" -type list\
-help "List of join directions, any of: up down left right
or those combined with another frametype e.g left-heavy down-light."
@ -6216,7 +6294,7 @@ tcl::namespace::eval textblock {
-help "-boxonly true restricts results to the corner,vertical and horizontal box elements
It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj."
@values -min 1
@values -min 1 -max -1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary."
memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
@ -7619,7 +7697,7 @@ tcl::namespace::eval textblock {
} -help "Perform an action on the frame cache."
}
proc frame_cache {args} {
set argd [punk::args::get_by_id ::textblock::frame_cache $args]
set argd [punk::args::parse $args withid ::textblock::frame_cache]
set action [dict get $argd values action]
variable frame_cache
set all_values_dict [dict get $argd values]
@ -7664,7 +7742,7 @@ tcl::namespace::eval textblock {
endindex -default "" -type indexexpression
}
proc frame_cache_display {args} {
set argd [punk::args::get_by_id ::textblock::frame_cache_display $args]
set argd [punk::args::parse $args withid ::textblock::frame_cache_display]
variable frame_cache
lassign [dict values [dict get $argd values]] startidx endidx
set limit ""
@ -7769,11 +7847,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 +7875,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 +7934,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 +7982,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 ""
@ -7928,7 +8025,6 @@ tcl::namespace::eval textblock {
#never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame
if {[llength $args] != 1 && (!$opts_ok || $check_args)} {
#as frame is called a lot within table building - checking args can have a *big* impact on final performance.
#set argd [punk::args::get_by_id ::textblock::frame $args]
set argd [punk::args::parse $args withid ::textblock::frame]
set opts [dict get $argd opts]
set contents [dict get $argd values contents]
@ -8530,7 +8626,8 @@ tcl::namespace::eval textblock {
#puts "frame--->ansiwrap -rawansi [ansistring VIEW $opt_ansibase] $cache_inner"
if {$opt_ansibase ne ""} {
if {[punk::ansi::ta::detect $cache_inner]} {
set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner]
#set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner]
set cache_inner [punk::ansi::ansiwrap_raw $opt_ansibase "" "" $cache_inner]
} else {
set cache_inner "$opt_ansibase$cache_inner\x1b\[0m"
}
@ -8561,7 +8658,8 @@ tcl::namespace::eval textblock {
#JMN test
#assert - lhs, cache_inner, rhs non-ragged - so can use join_basic REVIEW
#set cache_body [textblock::join -- {*}$cache_bodyparts]
set cache_body [textblock::join_basic -- {*}$cache_bodyparts]
#set cache_body [textblock::join_basic -- {*}$cache_bodyparts]
set cache_body [textblock::join_basic_raw {*}$cache_bodyparts]
append fscached $cache_body
#append fs $body
@ -8622,7 +8720,8 @@ tcl::namespace::eval textblock {
set contents_has_ansi [punk::ansi::ta::detect $contents]
if {$opt_ansibase ne ""} {
if {$contents_has_ansi} {
set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents]
#set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents]
set contents [punk::ansi::ansiwrap_raw $opt_ansibase "" "" $contents]
} else {
set contents "$opt_ansibase$contents\x1b\[0m"
set contents_has_ansi 1

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

@ -181,16 +181,18 @@ set startdir [pwd]
# -------------------------------------------------------------------------------------
set bootsupport_module_paths [list]
set bootsupport_library_paths [list]
#we always create these lists in order of desired precedence.
# - this is the same order when adding to auto_path - but will need to be reversed when using tcl:tm::add
if {[file exists [file join $startdir src bootsupport]]} {
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order
lappend bootsupport_module_paths [file join $startdir src bootsupport modules]
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv]
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $startdir src bootsupport lib]
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv]
} else {
lappend bootsupport_module_paths [file join $startdir bootsupport modules]
lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv]
lappend bootsupport_library_paths [file join $startdir bootsupport lib]
lappend bootsupport_module_paths [file join $startdir bootsupport modules]
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv]
lappend bootsupport_library_paths [file join $startdir bootsupport lib]
}
set bootsupport_paths_exist 0
foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] {
@ -210,13 +212,13 @@ set sourcesupport_paths_exist 0
#(most?) Modules in src/modules etc should still be runnable directly in certain cases like this where we point to them.
if {[file tail $startdir] eq "src"} {
#todo - other src 'module' dirs..
foreach p [list $startdir/modules $startdir/modules_tcl$::tclmajorv $startdir/vendormodules $startdir/vendormodules_tcl$::tclmajorv] {
foreach p [list $startdir/modules_tcl$::tclmajorv $startdir/modules $startdir/vendormodules_tcl$::tclmajorv $startdir/vendormodules] {
if {[file exists $p]} {
lappend sourcesupport_module_paths $p
}
}
# -- -- --
foreach p [list $startdir/lib $startdir/lib_tcl$::tclmajorv $startdir/vendorlib $startdir/vendorlib_tcl$::tclmajorv] {
foreach p [list $startdir/lib_tcl$::tclmajorv $startdir/lib $startdir/vendorlib_tcl$::tclmajorv $startdir/vendorlib] {
if {[file exists $p]} {
lappend sourcesupport_library_paths $p
}
@ -273,16 +275,48 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
package forget $pkg
}
}
#tcl::tm::add {*}$original_tm_list {*}$bootsupport_module_paths {*}$sourcesupport_module_paths
#set ::auto_path [list {*}$original_auto_path {*}$bootsupport_library_paths {*}$sourcesupport_library_paths]
tcl::tm::add {*}$bootsupport_module_paths {*}$sourcesupport_module_paths
set ::auto_path [list {*}$bootsupport_library_paths {*}$sourcesupport_library_paths]
#Deliberately omit original_tm_list and original_auto_path
tcl::tm::add {*}[lreverse $bootsupport_module_paths] {*}[lreverse $sourcesupport_module_paths] ;#tm::add works like LIFO. sourcesupport_module_paths end up earliest in resulting tm list.
set ::auto_path [list {*}$sourcesupport_library_paths {*}$bootsupport_library_paths]
}
puts "----> auto_path $::auto_path"
puts "----> tcl::tm::list [tcl::tm::list]"
#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"
}
}
#--------------------------------------------------------
#package require Thread
puts "---->tcl_library [info library]"
puts "---->loaded [info loaded]"
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly.
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list
@ -297,6 +331,8 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
package require punk::lib
package require punk::args
package require punk::ansi
package require textblock
set package_paths_modified 1
@ -1218,14 +1254,19 @@ if {$::punkboot::command eq "check"} {
}
# -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
# - package path restore original module paths and auto_path entries to take effect in addition to bootsupport paths
# - Order such that bootsupport entries are always higher priority (if same version number - prefer bootsupport)
# - This must be done between the two "check" command sections
if {$package_paths_modified} {
set tm_list_now [tcl::tm::list]
foreach p $original_tm_list {
if {$p ni $tm_list_now} {
set tm_list_boot [tcl::tm::list]
tcl::tm::remove {*}$tm_list_boot
foreach p [lreverse $original_tm_list] {
if {$p ni $tm_list_boot} {
tcl::tm::add $p
}
}
foreach p [lreverse $tm_list_boot] {
tcl::tm::add $p
}
#set ::auto_path [list $bootsupport_lib {*}$original_auto_path]
lappend ::auto_path {*}$original_auto_path
}
@ -1333,11 +1374,13 @@ if {$::punkboot::command eq "info"} {
if {$::punkboot::command eq "shell"} {
puts stderr ">>>>>> loaded:[info loaded]"
package require punk
package require punk::repl
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell"
#todo - make procs vars etc from this file available?
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell."
repl::init
repl::start stdin
@ -1504,7 +1547,7 @@ if {$::punkboot::command eq "bootsupport"} {
proc modfile_sort {p1 p2} {
lassign [split [file rootname $p1] -] _ v1
lassign [split [file rootname $p1] -] _ v2
lassign [split [file rootname $p2] -] _ v2
package vcompare $v1 $v2
}
proc bootsupport_localupdate {projectroot} {
@ -1543,7 +1586,10 @@ if {$::punkboot::command eq "bootsupport"} {
set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]]
set srclocation [file join $projectroot $relpath $module_subpath]
#puts stdout "$relpath $modulematch $module_subpath $srclocation"
if {[string first - $modulematch]} {
#we must always glob using the dash - or we will match libraries that are suffixes of others
#bare lib.tm with no version is not valid.
if {[string first - $modulematch] != -1} {
#version or part thereof is specified.
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm]
} else {
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm]
@ -1566,6 +1612,7 @@ if {$::punkboot::command eq "bootsupport"} {
#review
set copy_files $pkgmatches
}
#if a file added manually to target dir - there will be no .punkcheck record - will be detected as changed
foreach cfile $copy_files {
set srcfile [file join $srclocation $cfile]
set tgtfile [file join $targetroot $module_subpath $cfile]
@ -1574,6 +1621,8 @@ if {$::punkboot::command eq "bootsupport"} {
$boot_event targetset_init INSTALL $tgtfile
$boot_event targetset_addsource $srcfile
#----------
#
#puts "bootsuport target $tgtfile record size: [dict size [$boot_event targetset_last_complete]]"
if {\
[llength [dict get [$boot_event targetset_source_changes] changed]]\
|| [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\

21
src/vfs/_config/punk_main.tcl

@ -39,8 +39,12 @@ apply { args {
#standard way to avoid symlinking issues - review!
set normscript [file dirname [file normalize [file join [info script] __dummy__]]]
#The normalize is important as capitalisation must be retained (on all platforms)
set normexe [file dirname [file normalize [file join [info nameofexecutable] __dummy__]]]
puts stderr "STARKIT: [package provide starkit]"
set topdir [file dirname $normscript]
set found_starkit_tcl 0
set possible_lib_vfs_folders [glob -nocomplain -dir [file join $topdir lib] -type d vfs*]
@ -53,10 +57,13 @@ apply { args {
source $test_folder/pkgIndex.tcl
}
}
if {[set starkitv [lindex [package versions starkit] end]] ne ""} {
#package versions does not always return versions in increasing order!
if {[set starkitv [lindex [lsort -command {package vcompare} [package versions starkit]] end]] ne ""} {
#run the ifneeded script for the latest found (assuming package versions ordering is correct)
puts "111 autopath: $::auto_path"
eval [package ifneeded starkit $starkitv]
set found_starkit_tcl 1
puts "222 autopath: $::auto_path"
}
if {!$found_starkit_tcl} {
#our internal 'quick' search for starkit failed.
@ -124,6 +131,8 @@ apply { args {
if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} {
set kp $::tcl::kitpath
set kp [file normalize $kp] ;#tcl::kitpath needs to be capitalised as per the actual path
#set existing_module_paths [string tolower [tcl::tm::list]]
foreach p [list modules modules_tcl$tclmajorv] {
#if {[string tolower [file join $kp $p]] ni $existing_module_paths} {
@ -280,6 +289,7 @@ apply { args {
set external_tm_dirs [list]
set lcase_internal_paths [string tolower $internal_paths]
foreach tm $original_tm_list {
#review - do we know original tm list was properly normalised? (need capitalisation consistent for path keys)
set tmlower [string tolower $tm]
set is_internal 0
foreach okprefix $lcase_internal_paths {
@ -322,7 +332,8 @@ apply { args {
lappend exe_module_folders $normexe_dir/modules
lappend exe_module_folders $normexe_dir/modules_tcl$tclmajorv
}
set nameexe_dir [file dirname [info nameofexecutable]]
set nameexe_dir [file dirname [file normalize [info nameofexecutable]]] ;#must be normalized for capitalisation consistency
#possible symlink (may resolve to same path as above - we check below to not add in twice)
if {[file tail $nameexe_dir] eq "bin"} {
lappend exe_module_folders [file dirname $nameexe_dir]/modules
@ -379,14 +390,14 @@ apply { args {
}
} else {
#modules or modules_tclX subdir relative to cwd cannot be added if [pwd] has been added
set cwd_modules_folder [file normalize [file join [pwd] modules]]
set cwd_modules_folder [file join [pwd] modules] ;#pwd is already normalized to appropriate capitalisation
if {[file isdirectory $cwd_modules_folder]} {
if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} {
#prepend
set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder]
}
}
set cwd_modules_folder [file normalize [file join [pwd] modules_tcl$tclmajorv]]
set cwd_modules_folder [file join [pwd] modules_tcl$tclmajorv]
if {[file isdirectory $cwd_modules_folder]} {
if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} {
#prepend
@ -693,7 +704,7 @@ apply { args {
puts stderr "main.tcl tcl::tm::list:[tcl::tm::list]"
}
if {$has_zipfs_attached} {
if {1 || $has_zipfs_attached} {
#load libunknown without triggering the existing package unknown
#maint: also in punk::repl package

5317
src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm

File diff suppressed because it is too large Load Diff

5465
src/vfs/_vfscommon.vfs/modules/punk/args-0.1.1.tm

File diff suppressed because it is too large Load Diff

5465
src/vfs/_vfscommon.vfs/modules/punk/args-0.1.2.tm

File diff suppressed because it is too large Load Diff

5468
src/vfs/_vfscommon.vfs/modules/punk/args-0.1.3.tm

File diff suppressed because it is too large Load Diff

5745
src/vfs/_vfscommon.vfs/modules/punk/args-0.1.4.tm

File diff suppressed because it is too large Load Diff

Some files were not shown because too many files have changed in this diff Show More

Loading…
Cancel
Save