From 4773a6a56225db8b08b50c57f04f4b9f9aa24f32 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Sun, 13 Jul 2025 16:22:03 +1000 Subject: [PATCH] misc fixes, punk::args, repl timing, tclcore & tkcore docs, libunknown, test::punk::ansi testsuite beginning --- src/lib/app-punk/repl.tcl | 104 +- src/modules/argparsingtest-999999.0a1.0.tm | 37 +- src/modules/punk-0.1.tm | 179 +- src/modules/punk/aliascore-999999.0a1.0.tm | 2 + src/modules/punk/ansi-999999.0a1.0.tm | 1451 ++- .../punk/ansi/colourmap-999999.0a1.0.tm | 969 ++ .../punk/ansi/colourmap-buildversion.txt | 3 + src/modules/punk/args-999999.0a1.0.tm | 2321 ++-- src/modules/punk/args/tclcore-999999.0a1.0.tm | 954 +- src/modules/punk/args/tkcore-999999.0a1.0.tm | 622 ++ src/modules/punk/args/tkcore-buildversion.txt | 3 + src/modules/punk/console-999999.0a1.0.tm | 19 +- src/modules/punk/du-999999.0a1.0.tm | 1 + src/modules/punk/lib-999999.0a1.0.tm | 134 +- src/modules/punk/libunknown-0.1.tm | 723 +- src/modules/punk/mix-0.2.tm | 12 +- .../mix/commandset/module-999999.0a1.0.tm | 15 +- src/modules/punk/nav/fs-999999.0a1.0.tm | 3 +- src/modules/punk/ns-999999.0a1.0.tm | 49 +- .../punk/packagepreference-999999.0a1.0.tm | 60 +- src/modules/punk/path-999999.0a1.0.tm | 6 +- src/modules/punk/repl-999999.0a1.0.tm | 167 +- src/modules/punk/repl-buildversion.txt | 2 +- .../punk/repl/codethread-999999.0a1.0.tm | 2 +- src/modules/punk/safe-999999.0a1.0.tm | 2 +- ...hellfilter-0.1.9.tm => shellfilter-0.2.tm} | 185 +- .../ansi-0.1.1_testsuites/ansi/ansistrip.test | 80 + ...strip.test#..+ansi+ansistrip.test.fauxlink | 0 .../ansi-999999.0a1.0.tm | 225 + .../args-0.1.5_testsuites/args/args.test | 77 + src/modules/test/punk/ansi-buildversion.txt | 3 + src/modules/textblock-999999.0a1.0.tm | 3 +- src/vfs/_config/punk_main.tcl | 202 +- src/vfs/_vfscommon.vfs/lib/app-punk/repl.tcl | 2 + .../modules/argparsingtest-0.1.0.tm | 37 +- src/vfs/_vfscommon.vfs/modules/punk-0.1.tm | 202 +- .../modules/punk/aliascore-0.1.0.tm | 2 + .../_vfscommon.vfs/modules/punk/ansi-0.1.1.tm | 1451 ++- .../modules/punk/ansi/colourmap-0.1.0.tm | 969 ++ .../_vfscommon.vfs/modules/punk/args-0.1.9.tm | 1195 ++- .../_vfscommon.vfs/modules/punk/args-0.2.tm | 9550 +++++++++++++++++ .../modules/punk/args/tclcore-0.1.0.tm | 2440 ++++- .../modules/punk/args/tkcore-0.1.0.tm | 622 ++ .../modules/punk/console-0.1.1.tm | 25 +- .../_vfscommon.vfs/modules/punk/du-0.1.0.tm | 1 + .../_vfscommon.vfs/modules/punk/lib-0.1.2.tm | 135 +- .../modules/punk/libunknown-0.1.tm | 723 +- .../_vfscommon.vfs/modules/punk/mix-0.2.tm | 12 +- .../punk/mix/commandset/module-0.1.0.tm | 15 +- .../modules/punk/nav/fs-0.1.0.tm | 3 +- .../_vfscommon.vfs/modules/punk/ns-0.1.0.tm | 146 +- .../modules/punk/packagepreference-0.1.0.tm | 60 +- .../_vfscommon.vfs/modules/punk/path-0.1.0.tm | 6 +- .../_vfscommon.vfs/modules/punk/repl-0.1.1.tm | 10 +- .../_vfscommon.vfs/modules/punk/repl-0.1.2.tm | 3661 +++++++ .../modules/punk/repl/codethread-0.1.1.tm | 2 +- .../_vfscommon.vfs/modules/punk/safe-0.1.0.tm | 2 +- .../_vfscommon.vfs/modules/punk/zip-0.1.1.tm | 13 +- .../_vfscommon.vfs/modules/shellfilter-0.2.tm | 3322 ++++++ .../_vfscommon.vfs/modules/shellrun-0.1.1.tm | 107 +- .../modules/test/punk/ansi-0.1.1.tm | Bin 0 -> 10188 bytes .../modules/test/punk/args-0.1.5.tm | Bin 13175 -> 14299 bytes .../_vfscommon.vfs/modules/textblock-0.1.3.tm | 179 +- 63 files changed, 30434 insertions(+), 3073 deletions(-) create mode 100644 src/modules/punk/ansi/colourmap-999999.0a1.0.tm create mode 100644 src/modules/punk/ansi/colourmap-buildversion.txt create mode 100644 src/modules/punk/args/tkcore-999999.0a1.0.tm create mode 100644 src/modules/punk/args/tkcore-buildversion.txt rename src/modules/{shellfilter-0.1.9.tm => shellfilter-0.2.tm} (95%) create mode 100644 src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-0.1.1_testsuites/ansi/ansistrip.test create mode 100644 src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-0.1.1_testsuites/tests/ansistrip.test#..+ansi+ansistrip.test.fauxlink create mode 100644 src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-999999.0a1.0.tm create mode 100644 src/modules/test/punk/ansi-buildversion.txt create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/ansi/colourmap-0.1.0.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/args/tkcore-0.1.0.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/test/punk/ansi-0.1.1.tm diff --git a/src/lib/app-punk/repl.tcl b/src/lib/app-punk/repl.tcl index 8bc7d461..ee01e7a9 100644 --- a/src/lib/app-punk/repl.tcl +++ b/src/lib/app-punk/repl.tcl @@ -1,51 +1,53 @@ -package provide app-punk 1.0 -#punk linerepl launcher - -#By the time we get here, we don't expect other packages to have been loaded - but the lib/module paths have already been scanned to populate 'package names' - - -#puts stdout "$::auto_path" -#puts stderr "-----------" -#puts stderr "tcl::tm::list" -#puts stderr "-----------" -#puts stderr "[join [tcl::tm::list] \n]" -#puts stderr "-----------" -#puts stderr "auto_path" -#puts stderr "-----------" -#puts stderr "[join $::auto_path \n]" -#puts stderr "-----------" -#puts stderr "thread? [package provide Thread]" -set thread_version [package require Thread] -#puts stderr "repl.tcl thread version:$thread_version" -#puts stderr "info loaded:" -#puts stderr [join [info loaded] \n] - -#set tpath [lindex [info loaded] 0 0] -#puts stdout "--$tpath--" -#puts stdout "--[file exists $tpath]--" -#set tid [thread::create -preserved] -#thread::send $tid {puts thread1} -#puts stdout "mythread: [thread::id]" - -#review -#catch {package require tcllibc} - -#punk & shellrun should be in codethreads - but not required in the parent repl threads -package require shellfilter - -package require punk::repl -#puts stderr "package names" -#set packages_present [list] -#foreach p [package names] { -# if {[package provide $p] ne ""} { -# lappend packages_present $p -# } -#} -#puts stderr [join $packages_present \n] -repl::init -safe 0 -#puts stderr "Launching repl::start stdin -title app-punk" -#flush stderr -repl::start stdin -title app-punk -#puts "- repl app done -" -#flush stdout - +package provide app-punk 1.0 +#punk linerepl launcher + +#By the time we get here, we don't expect other packages to have been loaded - but the lib/module paths have already been scanned to populate 'package names' + + +#puts stdout "$::auto_path" +#puts stderr "-----------" +#puts stderr "tcl::tm::list" +#puts stderr "-----------" +#puts stderr "[join [tcl::tm::list] \n]" +#puts stderr "-----------" +#puts stderr "auto_path" +#puts stderr "-----------" +#puts stderr "[join $::auto_path \n]" +#puts stderr "-----------" +#puts stderr "thread? [package provide Thread]" +set thread_version [package require Thread] +#puts stderr "repl.tcl thread version:$thread_version" +#puts stderr "info loaded:" +#puts stderr [join [info loaded] \n] + +#set tpath [lindex [info loaded] 0 0] +#puts stdout "--$tpath--" +#puts stdout "--[file exists $tpath]--" +#set tid [thread::create -preserved] +#thread::send $tid {puts thread1} +#puts stdout "mythread: [thread::id]" + +#review +#catch {package require tcllibc} + +#punk & shellrun should be in codethreads - but not required in the parent repl threads +package require shellfilter + +package require punk::repl +#set v [package provide punk::repl] +#puts stderr "punk::repl version:$v script: [package ifneeded punk::repl $v]" +#puts stderr "package names" +#set packages_present [list] +#foreach p [package names] { +# if {[package provide $p] ne ""} { +# lappend packages_present $p +# } +#} +#puts stderr [join $packages_present \n] +repl::init -safe 0 +#puts stderr "Launching repl::start stdin -title app-punk" +#flush stderr +repl::start stdin -title app-punk +#puts "- repl app done -" +#flush stdout + diff --git a/src/modules/argparsingtest-999999.0a1.0.tm b/src/modules/argparsingtest-999999.0a1.0.tm index 8991b7fc..31f69dc9 100644 --- a/src/modules/argparsingtest-999999.0a1.0.tm +++ b/src/modules/argparsingtest-999999.0a1.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 diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index b92b106e..82a81432 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -515,6 +515,7 @@ namespace eval punk { #proc ::objclone {obj} { # append obj2 $obj {} #} + #----------------------------------------------------------------------------------- #order of arguments designed for pipelining #review - 'piper_' prefix is a naming convention for functions that are ordered for tail-argument pipelining @@ -530,6 +531,152 @@ namespace eval punk { proc ::punk::K {x y} { return $x} + #todo ansigrep? e.g grep using ansistripped value + proc grepstr1 {pattern data} { + set data [string map {\r\n \n} $data] + set lines [split $data \n] + set matches [lsearch -all -regexp $lines $pattern] + set max [lindex $matches end] + set w1 [string length $max] + set result "" + set H [a+ green bold overline] + set R \x1b\[m + foreach m $matches { + set ln [lindex $lines $m] + set ln [regsub -all $pattern $ln $H&$R] + append result [format %${w1}s $m] " $ln" \n + } + set result [string trimright $result \n] + return $result + } + + #---------------------- + #todo - fix overtype + #create test + #overtype::renderline -insert_mode 0 -transparent 1 [a+ green]-----[a] " [a+ underline]x[a]" + #---------------------- + + + punk::args::define { + @id -id ::punk::grepstr + @cmd -name punk::grepstr\ + -summary\ + "Grep for regex pattern in supplied (possibly ANSI) string."\ + -help\ + "" + @leaders -min 0 -max 0 + @opts + -returnlines -type string -default all -choices {matched all} + -ansistrip -type none + -no-linenumbers -type none + -highlight -type list -typesynopsis ansinames -default {green bold Black underline overline} -help\ + "list of ANSI SGR style codes as supported by and documented in punk::ansi::a?" + -- -type none + @values + pattern -type string -help\ + "regex pattern to match in plaintext portion of ANSI string" + string -type string + } + proc grepstr {args} { + lassign [dict values [punk::args::parse $args withid ::punk::grepstr]] leaders opts values received + set pattern [dict get $values pattern] + set data [dict get $values string] + set do_strip 0 + if {[dict exists $received -ansistrip]} { + set data [punk::ansi::ansistrip $data] + } + set highlight [dict get $opts -highlight] + set returnlines [dict get $opts -returnlines] + if {[dict exists $received -no-linenumbers]} { + set do_linenums 0 + } else { + set do_linenums 1 + } + + if {[llength $highlight] == 0} { + set H "" + set R "" + } else { + set H [a+ {*}$highlight] + set R \x1b\[m + } + + set data [string map {\r\n \n} $data] + if {![punk::ansi::ta::detect $data]} { + set lines [split $data \n] + set matches [lsearch -all -regexp $lines $pattern] + set result "" + if {$returnlines eq "all"} { + set returnlines [punk::lib::range 0 [llength $lines]-1] + } else { + set returnlines $matches + } + set max [lindex $returnlines end] + set w1 [string length $max] + foreach linenum $returnlines { + if {$do_linenums} { + set col1 "[format %${w1}s $linenum] " + } else { + set col1 "" + } + set ln [lindex $lines $linenum] + if {$linenum in $matches} { + set ln [regsub -all -- $pattern $ln $H&$R] + } + append result $col1 $ln \n + } + set result [string trimright $result \n] + return $result + } else { + set plain [punk::ansi::ansistrip $data] + set plainlines [split $plain \n] + set lines [split $data \n] + set matches [lsearch -all -regexp $plainlines $pattern] + if {$returnlines eq "all"} { + set returnlines [punk::lib::range 0 [llength $lines]-1] + } else { + set returnlines $matches + } + set max [lindex $returnlines end] + set w1 [string length $max] + set result "" + set placeholder \UFFEF ;#review + foreach linenum $returnlines { + set ln [lindex $lines $linenum] + if {$do_linenums} { + set col1 "[format %${w1}s $linenum] " + } else { + set col1 "" + } + if {$linenum in $matches} { + set plain_ln [lindex $plainlines $linenum] + set parts [regexp -all -indices -inline -- $pattern $plain_ln] + if {[llength $parts] == 0} { + #shouldn't happen + append result $col1 $ln \n + } else { + set overlay "" + set i 0 + foreach prange $parts { + lassign $prange s e + set prelen [expr {$s - $i}] + append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]$R + set i [expr {$e + 1}] + } + set tail [string range $plain_ln $e+1 end] + append overlay [string repeat $placeholder [string length $tail]] + #puts "$overlay" + #puts "$ln" + append result $col1 [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay] \n + } + } else { + append result $col1 $ln \n + } + } + return $result + } + } + proc stacktrace {} { set stack "Stack trace:\n" for {set i 1} {$i < [info level]} {incr i} { @@ -7510,27 +7657,33 @@ namespace eval punk { set indent [string repeat " " [string length "WARNING: "]] lappend cstring_tests [dict create\ type "PM "\ - msg "PRIVACY MESSAGE"\ + msg "UN"\ f7 punk::ansi::controlstring_PM\ - f7desc "7bit ESC ^"\ + f7prefix "7bit ESC ^ secret "\ + f7suffix "safe"\ f8 punk::ansi::controlstring_PM8\ - f8desc "8bit \\x9e"\ + f8prefix "8bit \\x9e secret "\ + f8suffix "safe"\ ] lappend cstring_tests [dict create\ type SOS\ - msg "STRING"\ + msg "NOT"\ f7 punk::ansi::controlstring_SOS\ - f7desc "7bit ESC X"\ + f7prefix "7bit ESC X string "\ + f7suffix " hidden"\ f8 punk::ansi::controlstring_SOS8\ - f8desc "8bit \\x98"\ + f8prefix "8bit \\x98 string "\ + f8suffix " hidden"\ ] lappend cstring_tests [dict create\ type APC\ - msg "APPLICATION PROGRAM COMMAND"\ + msg "NOT"\ f7 punk::ansi::controlstring_APC\ - f7desc "7bit ESC _"\ + f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ + f7suffix " hidden"\ f8 punk::ansi::controlstring_APC8\ - f8desc "8bit \\x9f"\ + f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ + f8suffix " hidden"\ ] foreach test $cstring_tests { @@ -7540,14 +7693,14 @@ namespace eval punk { set hidden_width_m8 [punk::console::test_char_width $m8] if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { if {$hidden_width_m == 0} { - set d "[a+ green bold][dict get $test f7desc] [a red]${m}[a]" + set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" } else { - set d "[a+ yellow bold][dict get $test f7desc] [a red]$m[a]" + set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" } if {$hidden_width_m8 == 0} { - set d8 "[a+ green ][dict get $test f8desc] [a red]$m8[a]" + set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" } else { - set d8 "[a+ yellow bold][dict get $test f8desc] [a red]$m8[a]" + set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" } append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } diff --git a/src/modules/punk/aliascore-999999.0a1.0.tm b/src/modules/punk/aliascore-999999.0a1.0.tm index f2ddb1b6..0c41af06 100644 --- a/src/modules/punk/aliascore-999999.0a1.0.tm +++ b/src/modules/punk/aliascore-999999.0a1.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 diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 238174c1..450099be 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -611,7 +611,7 @@ tcl::namespace::eval punk::ansi { } ""] proc example {args} { - set argd [punk::args::get_by_id ::punk::ansi::example $args] + set argd [punk::args::parse $args withid ::punk::ansi::example] set colwidth [dict get $argd opts -colwidth] if {[info commands file] eq ""} { error "file command unavailable - punk::ansi::example cannot be shown" @@ -876,6 +876,7 @@ tcl::namespace::eval punk::ansi { tlc l\ trc k\ blc m\ + brc j\ ltj t\ rtj u\ ttj w\ @@ -985,51 +986,51 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #css 1-2.0 HTML 3.2-4 Basic colours eg web-silver for fg Web-silver for bg # variable WEB_colour_map_basic - tcl::dict::set WEB_colour_map_basic white 255-255-255 ;# #FFFFFF - tcl::dict::set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 - tcl::dict::set WEB_colour_map_basic gray 128-128-128 ;# #808080 - tcl::dict::set WEB_colour_map_basic black 0-0-0 ;# #000000 - tcl::dict::set WEB_colour_map_basic red 255-0-0 ;# #FF0000 - tcl::dict::set WEB_colour_map_basic maroon 128-0-0 ;# #800000 - tcl::dict::set WEB_colour_map_basic yellow 255-255-0 ;# #FFFF00 - tcl::dict::set WEB_colour_map_basic olive 128-128-0 ;# #808000 - tcl::dict::set WEB_colour_map_basic lime 0-255-0 ;# #00FF00 - tcl::dict::set WEB_colour_map_basic green 0-128-0 ;# #008000 - tcl::dict::set WEB_colour_map_basic aqua 0-255-255 ;# #00FFFF - tcl::dict::set WEB_colour_map_basic teal 0-128-128 ;# #008080 - tcl::dict::set WEB_colour_map_basic blue 0-0-255 ;# #0000FF - tcl::dict::set WEB_colour_map_basic navy 0-0-128 ;# #000080 - tcl::dict::set WEB_colour_map_basic fuchsia 255-0-255 ;# #FF00FF - tcl::dict::set WEB_colour_map_basic purple 128-0-128 ;# #800080 + tcl::dict::set WEB_colour_map_basic white 255-255-255 ;# #FFFFFF + tcl::dict::set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 + tcl::dict::set WEB_colour_map_basic gray 128-128-128 ;# #808080 + tcl::dict::set WEB_colour_map_basic black 0-0-0 ;# #000000 + tcl::dict::set WEB_colour_map_basic red 255-0-0 ;# #FF0000 + tcl::dict::set WEB_colour_map_basic maroon 128-0-0 ;# #800000 + tcl::dict::set WEB_colour_map_basic yellow 255-255-0 ;# #FFFF00 + tcl::dict::set WEB_colour_map_basic olive 128-128-0 ;# #808000 + tcl::dict::set WEB_colour_map_basic lime 0-255-0 ;# #00FF00 + tcl::dict::set WEB_colour_map_basic green 0-128-0 ;# #008000 + tcl::dict::set WEB_colour_map_basic aqua 0-255-255 ;# #00FFFF + tcl::dict::set WEB_colour_map_basic teal 0-128-128 ;# #008080 + tcl::dict::set WEB_colour_map_basic blue 0-0-255 ;# #0000FF + tcl::dict::set WEB_colour_map_basic navy 0-0-128 ;# #000080 + tcl::dict::set WEB_colour_map_basic fuchsia 255-0-255 ;# #FF00FF + tcl::dict::set WEB_colour_map_basic purple 128-0-128 ;# #800080 # -- --- --- #Pink colours variable WEB_colour_map_pink - tcl::dict::set WEB_colour_map_pink mediumvioletred 199-21-133 ;# #C71585 - tcl::dict::set WEB_colour_map_pink deeppink 255-20-147 ;# #FF1493 - tcl::dict::set WEB_colour_map_pink palevioletred 219-112-147 ;# #DB7093 - tcl::dict::set WEB_colour_map_pink hotpink 255-105-180 ;# #FF69B4 - tcl::dict::set WEB_colour_map_pink lightpink 255-182-193 ;# #FFB6C1 - tcl::dict::set WEB_colour_map_pink pink 255-192-203 ;# #FFCOCB + tcl::dict::set WEB_colour_map_pink mediumvioletred 199-21-133 ;# #C71585 + tcl::dict::set WEB_colour_map_pink deeppink 255-20-147 ;# #FF1493 + tcl::dict::set WEB_colour_map_pink palevioletred 219-112-147 ;# #DB7093 + tcl::dict::set WEB_colour_map_pink hotpink 255-105-180 ;# #FF69B4 + tcl::dict::set WEB_colour_map_pink lightpink 255-182-193 ;# #FFB6C1 + tcl::dict::set WEB_colour_map_pink pink 255-192-203 ;# #FFCOCB # -- --- --- #Red colours variable WEB_colour_map_red - tcl::dict::set WEB_colour_map_red darkred 139-0-0 ;# #8B0000 - tcl::dict::set WEB_colour_map_red red 255-0-0 ;# #FF0000 - tcl::dict::set WEB_colour_map_red firebrick 178-34-34 ;# #B22222 - tcl::dict::set WEB_colour_map_red crimson 220-20-60 ;# #DC143C - tcl::dict::set WEB_colour_map_red indianred 205-92-92 ;# #CD5C5C - tcl::dict::set WEB_colour_map_red lightcoral 240-128-128 ;# #F08080 - tcl::dict::set WEB_colour_map_red salmon 250-128-114 ;# #FA8072 - tcl::dict::set WEB_colour_map_red darksalmon 233-150-122 ;# #E9967A - tcl::dict::set WEB_colour_map_red lightsalmon 255-160-122 ;# #FFA07A + tcl::dict::set WEB_colour_map_red darkred 139-0-0 ;# #8B0000 + tcl::dict::set WEB_colour_map_red red 255-0-0 ;# #FF0000 + tcl::dict::set WEB_colour_map_red firebrick 178-34-34 ;# #B22222 + tcl::dict::set WEB_colour_map_red crimson 220-20-60 ;# #DC143C + tcl::dict::set WEB_colour_map_red indianred 205-92-92 ;# #CD5C5C + tcl::dict::set WEB_colour_map_red lightcoral 240-128-128 ;# #F08080 + tcl::dict::set WEB_colour_map_red salmon 250-128-114 ;# #FA8072 + tcl::dict::set WEB_colour_map_red darksalmon 233-150-122 ;# #E9967A + tcl::dict::set WEB_colour_map_red lightsalmon 255-160-122 ;# #FFA07A # -- --- --- #Orange colours variable WEB_colour_map_orange - tcl::dict::set WEB_colour_map_orange orangered 255-69-0 ;# #FF4500 - tcl::dict::set WEB_colour_map_orange tomato 255-99-71 ;# #FF6347 - tcl::dict::set WEB_colour_map_orange darkorange 255-140-0 ;# #FF8C00 - tcl::dict::set WEB_colour_map_orange coral 255-127-80 ;# #FF7F50 - tcl::dict::set WEB_colour_map_orange orange 255-165-0 ;# #FFA500 + tcl::dict::set WEB_colour_map_orange orangered 255-69-0 ;# #FF4500 + tcl::dict::set WEB_colour_map_orange tomato 255-99-71 ;# #FF6347 + tcl::dict::set WEB_colour_map_orange darkorange 255-140-0 ;# #FF8C00 + tcl::dict::set WEB_colour_map_orange coral 255-127-80 ;# #FF7F50 + tcl::dict::set WEB_colour_map_orange orange 255-165-0 ;# #FFA500 # -- --- --- #Yellow colours variable WEB_colour_map_yellow @@ -1041,7 +1042,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_yellow palegoldenrod 238-232-170 ;# #EEE8AA tcl::dict::set WEB_colour_map_yellow moccasin 255-228-181 ;# #FFE4B5 tcl::dict::set WEB_colour_map_yellow papayawhip 255-239-213 ;# #FFEFD5 - tcl::dict::set WEB_colour_map_yellow lightgoldenrodyeallow 250-250-210 ;# #FAFAD2 + tcl::dict::set WEB_colour_map_yellow lightgoldenrodyeallow 250-250-210 ;# #FAFAD2 tcl::dict::set WEB_colour_map_yellow lemonchiffon 255-250-205 ;# #FFFACD tcl::dict::set WEB_colour_map_yellow lightyellow 255-255-224 ;# #FFFFE0 # -- --- --- @@ -1068,7 +1069,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #Purple, violet, and magenta colours variable WEB_colour_map_purple tcl::dict::set WEB_colour_map_purple indigo 75-0-130 ;# #4B0082 - tcl::dict::set WEB_colour_map_purple purple 128-0-128 ;# #800080 + tcl::dict::set WEB_colour_map_purple purple 128-0-128 ;# #800080 tcl::dict::set WEB_colour_map_purple darkmagenta 139-0-139 ;# #8B008B tcl::dict::set WEB_colour_map_purple darkviolet 148-0-211 ;# #9400D3 tcl::dict::set WEB_colour_map_purple darkslateblue 72-61-139 ;# #9400D3 @@ -1089,10 +1090,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #Blue colours variable WEB_colour_map_blue tcl::dict::set WEB_colour_map_blue midnightblue 25-25-112 ;# #191970 - tcl::dict::set WEB_colour_map_blue navy 0-0-128 ;# #000080 + tcl::dict::set WEB_colour_map_blue navy 0-0-128 ;# #000080 tcl::dict::set WEB_colour_map_blue darkblue 0-0-139 ;# #00008B tcl::dict::set WEB_colour_map_blue mediumblue 0-0-205 ;# #0000CD - tcl::dict::set WEB_colour_map_blue blue 0-0-255 ;# #0000FF + tcl::dict::set WEB_colour_map_blue blue 0-0-255 ;# #0000FF tcl::dict::set WEB_colour_map_blue royalblue 65-105-225 ;# #4169E1 tcl::dict::set WEB_colour_map_blue steelblue 70-130-180 ;# #4682B4 tcl::dict::set WEB_colour_map_blue dodgerblue 30-144-255 ;# #1E90FF @@ -1113,7 +1114,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_cyan darkturquoise 0-206-209 ;# #00CED1 tcl::dict::set WEB_colour_map_cyan mediumturquoise 72-209-204 ;# #48D1CC tcl::dict::set WEB_colour_map_cyan turquoise 64-224-208 ;# #40E0D0 - tcl::dict::set WEB_colour_map_cyan aqua 0-255-255 ;# #00FFFF + tcl::dict::set WEB_colour_map_cyan aqua 0-255-255 ;# #00FFFF tcl::dict::set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua tcl::dict::set WEB_colour_map_cyan aquamarine 127-255-212 ;# #7FFFD4 tcl::dict::set WEB_colour_map_cyan paleturquoise 175-238-238 ;# #AFEEEE @@ -1126,11 +1127,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_green darkolivegreen 85-107-47 ;# #55682F tcl::dict::set WEB_colour_map_green forestgreen 34-139-34 ;# #228B22 tcl::dict::set WEB_colour_map_green seagreen 46-139-87 ;# #2E8B57 - tcl::dict::set WEB_colour_map_green olive 128-128-0 ;# #808000 + tcl::dict::set WEB_colour_map_green olive 128-128-0 ;# #808000 tcl::dict::set WEB_colour_map_green olivedrab 107-142-35 ;# #6B8E23 tcl::dict::set WEB_colour_map_green mediumseagreen 60-179-113 ;# #3CB371 tcl::dict::set WEB_colour_map_green limegreen 50-205-50 ;# #32CD32 - tcl::dict::set WEB_colour_map_green lime 0-255-0 ;# #00FF00 + tcl::dict::set WEB_colour_map_green lime 0-255-0 ;# #00FF00 tcl::dict::set WEB_colour_map_green springgreen 0-255-127 ;# #00FF7F tcl::dict::set WEB_colour_map_green mediumspringgreen 0-250-154 ;# #00FA9A tcl::dict::set WEB_colour_map_green darkseagreen 143-188-143 ;# #8FBC8F @@ -1160,15 +1161,15 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_white mintcream 245-255-250 ;# #F5FFFA tcl::dict::set WEB_colour_map_white snow 255-250-250 ;# #FFFAFA tcl::dict::set WEB_colour_map_white ivory 255-255-240 ;# #FFFFF0 - tcl::dict::set WEB_colour_map_white white 255-255-255 ;# #FFFFFF + tcl::dict::set WEB_colour_map_white white 255-255-255 ;# #FFFFFF # -- --- --- #Gray and black colours variable WEB_colour_map_gray - tcl::dict::set WEB_colour_map_gray black 0-0-0 ;# #000000 + tcl::dict::set WEB_colour_map_gray black 0-0-0 ;# #000000 tcl::dict::set WEB_colour_map_gray darkslategray 47-79-79 ;# #2F4F4F tcl::dict::set WEB_colour_map_gray dimgray 105-105-105 ;# #696969 tcl::dict::set WEB_colour_map_gray slategray 112-128-144 ;# #708090 - tcl::dict::set WEB_colour_map_gray gray 128-128-128 ;# #808080 + tcl::dict::set WEB_colour_map_gray gray 128-128-128 ;# #808080 tcl::dict::set WEB_colour_map_gray lightslategray 119-136-153 ;# #778899 tcl::dict::set WEB_colour_map_gray darkgray 169-169-169 ;# #A9A9A9 tcl::dict::set WEB_colour_map_gray silver 192-192-192 ;# #C0C0C0 @@ -1201,6 +1202,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set X11_colour_map [tcl::dict::merge $WEB_colour_map $X11_colour_map_diff] + + + + #Xterm colour names (256 colours) #lists on web have duplicate names #these have been renamed here in a systematic way: @@ -1217,6 +1222,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #The xterm names are boringly unimaginative - and also have some oddities such as: # DarkSlateGray1 which looks much more like cyan.. # The greyxx names are spelt with an e - but the darkslategrayX variants use an a. Perhaps that's because they are more cyan than grey and the a is a hint? + #(more likely just a mix of UK vs US spelling) # there is no gold or gold2 - but there is gold1 and gold3 #but in general the names bear some resemblance to the colours and are at least somewhat intuitive. @@ -1612,7 +1618,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fg "black" } } - lappend clist "[a+ {*}$fc {*}$fg Term$i][format %3s $i]" + lappend clist "[a+ {*}$fc {*}$fg Term-$i][format %3s $i]" } set t [textblock::list_as_table -columns 36 -return tableobject $clist] @@ -1636,7 +1642,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {$i > 8} { set fg "web-black" } - append out "[a+ {*}$fc {*}$fg Term$i][format %3s $i] " + append out "[a+ {*}$fc {*}$fg Term-$i][format %3s $i] " } return $out[a] } @@ -1698,7 +1704,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { set br "" } - append out "$br[a+ {*}$fc {*}$fg Term$i][format %3s $i] " + append out "$br[a+ {*}$fc {*}$fg Term-$i][format %3s $i] " } append out [a] return [tcl::string::trimleft $out \n] @@ -1723,7 +1729,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set t [textblock::class::table new] $t configure -show_seps 0 -show_edge 0 for {set i 16} {$i <=231} {incr i} { - set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-cname etc instead of term$i - may as well let a+ cache the call by name as the preferred? option + set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-cname etc instead of term-$i - may as well let a+ cache the call by name as the preferred? option if {[llength $row]== $cols} { lappend rows $row set row [list] @@ -1792,7 +1798,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu foreach cnum $pastel8 { append p8 "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] " } - append p8 [a]\n + #append p8 [a]\n + #append out \n $p8 + + append p8 [a] append out \n $p8 return $out @@ -1879,7 +1888,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {$i > 243} { set fg "web-black" } - append out "[a+ {*}$fc {*}$fg Term$i][format %3s $i] " + append out "[a+ {*}$fc {*}$fg Term-$i][format %3s $i] " } return $out[a] @@ -1899,7 +1908,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set t [textblock::class::table new] $t configure -show_hseps 0 -show_edge 0 for {set i 232} {$i <=255} {incr i} { - set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-cname etc instead of term$i - may as well let a+ cache the call by name as the preferred? option + set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-cname etc instead of term-$i - may as well let a+ cache the call by name as the preferred? option if {[llength $row]== 8} { lappend rows $row set row [list] @@ -1919,6 +1928,169 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return [tcl::string::trimleft $out \n] } + + if {[catch {package require punk::ansi::colourmap} errM]} { + puts stderr "punk::ansi FAILED to load punk::ansi::colourmap\n$errM" + } + if {[info exists ::punk::ansi::colourmap::TK_colour_map]} { + upvar ::punk::ansi::colourmap::TK_colour_map TK_colour_map + upvar ::punk::ansi::colourmap::TK_colour_map_lookup TK_colour_map_lookup + } else { + puts stderr "Failed to find TK_colour_map - punk::ansi::colourmap package not loaded?" + variable TK_colour_map {} + variable TK_colour_map_lookup {} + } + + #order-preserving + proc lunique {list} { + set new {} + foreach item $list { + if {$item ni $new} { + lappend new $item + } + } + return $new + } + + proc colourtable_tk {args} { + set opts {-forcecolour 0 -groups * -merged 0 -globs *} + foreach {k v} $args { + switch -- $k { + -groups - -merged - -forcecolour - -globs { + tcl::dict::set opts $k $v + } + default { + error "colourtable_tk unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]" + } + } + } + set fc "" + if {[tcl::dict::get $opts -forcecolour]} { + set fc "forcecolour" + } + + #not implemented - todo? Tk + set groups [tcl::dict::get $opts -groups] + + set do_merge [tcl::dict::get $opts -merged] + set globs [tcl::dict::get $opts -globs] + + + + set blocklist [list] ;#vertical blocks consisting of blockrows + set blockrow [list] + set height 50 ;#number of lines (excluding header) vertically in a blockrow + set columns 5 ;#number of columns in a blockrow + set i -1 + set t "" + set start 0 + set colidx -1 + variable TK_colour_map ;#use the version without lowercased additions - this gives the display names with casing as shown in Tk colour man page. + if {!$do_merge} { + set map $TK_colour_map + if {$globs eq "*"} { + set keys [dict keys $TK_colour_map] + } else { + set keys [list] + set mapkeys [dict keys $TK_colour_map] + foreach g $globs { + #lappend keys {*}[dict keys $map $g] + #need case insensitive globs for convenience. + lappend keys {*}[lsearch -all -glob -inline -nocase $mapkeys $g] + } + set keys [lunique $keys] + } + } else { + #todo - make glob fully search when do_merge + #needs to get keys from all names - but then map to keys that have dependent names + upvar ::punk::ansi::colourmap::TK_colour_map_merge map + upvar ::punk::ansi::colourmap::TK_colour_map_reverse reversemap + if {$globs eq "*"} { + set keys [dict keys $map] + } else { + set keys [list] + set allkeys [dict keys $TK_colour_map] + + foreach g $globs { + set matchedkeys [lsearch -all -glob -inline -nocase $allkeys $g] + foreach m $matchedkeys { + if {![dict exists $map $m]} { + #not a parent in a merge + set rgb [dict get $TK_colour_map $m] + set names [dict get $reversemap $rgb] + #first name is the one that is in the merge map + lappend keys [lindex $names 0] + } else { + lappend keys $m + } + } + } + set keys [lunique $keys] + } + } + set overheight 0 + + + foreach cname $keys { + set data [dict get $map $cname] + incr i + if {$overheight || $i % $height == 0} { + set overheight 0 + incr colidx + if {$t ne ""} { + $t configure -frametype {} + $t configure_column 0 -headers [list "TK colours $start - $i"] + $t configure_column 0 -header_colspans [list any] + $t configure -ansibase_header [a+ {*}$fc web-black Web-white] + lappend blockrow [$t print] " " + $t destroy + if {$colidx % $columns == 0} { + lappend blocklist $blockrow + set blockrow [list] + } + } + set start $i + set t [textblock::class::table new] + $t configure -show_edge 0 -show_seps 0 -show_header 1 -minwidth 42 + } + if {!$do_merge} { + set cdec $data + $t add_row [list $cname " [colour_dec2hex $cdec] " $cdec] + } else { + set cdec [dict get $data colour] + set othernames [dict get $data names] + set ndisplay [join [list $cname {*}$othernames] \n] + $t add_row [list $ndisplay " [colour_dec2hex $cdec] " $cdec] + set overheight 0 + foreach n $othernames { + incr i + if {$i % $height == 0} { + set overheight 1 + } + } + } + set fg "rgb-$cdec-contrasting" + $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] + } + if {$i == 0 || $i % $height != 0} { + if {$t ne ""} { + $t configure -frametype {} + $t configure_column 0 -headers [list "TK colours $start - $i"] + $t configure_column 0 -header_colspans [list any] + $t configure -ansibase_header [a+ {*}$fc web-black Web-white] + lappend blockrow [$t print] " " + lappend blocklist $blockrow + $t destroy + } + } + set result "" + foreach blockrow $blocklist { + append result [textblock::join -- {*}$blockrow] \n + } + + return $result + } + #set WEB_colour_map [tcl::dict::merge\ # $WEB_colour_map_basic\ # $WEB_colour_map_pink\ @@ -1970,17 +2142,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } set grouptables [list] - set white_fg_list [list\ - mediumvioletred deeppink\ - darkred red firebrick crimson indianred\ - orangered\ - maroon brown saddlebrown sienna\ - indigo purple darkmagenta darkviolet darkslateblue blueviolet darkorchid fuchsia magenta slateblue mediumslateblue\ - midnightblue navy darkblue mediumblue blue royalblue steelblue dodgerblue\ - teal darkcyan\ - darkgreen green darkolivegreen forestgreen seagreen olive olivedrab\ - black darkslategray dimgray slategray\ - ] + #set white_fg_list [list\ + # mediumvioletred deeppink\ + # darkred red firebrick crimson indianred\ + # orangered\ + # maroon brown saddlebrown sienna\ + # indigo purple darkmagenta darkviolet darkslateblue blueviolet darkorchid fuchsia magenta slateblue mediumslateblue\ + # midnightblue navy darkblue mediumblue blue royalblue steelblue dodgerblue\ + # teal darkcyan\ + # darkgreen green darkolivegreen forestgreen seagreen olive olivedrab\ + # black darkslategray dimgray slategray\ + # ] foreach g $show_groups { #upvar WEB_colour_map_$g map_$g variable WEB_colour_map_$g @@ -1988,11 +2160,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu $t configure -show_edge 0 -show_seps 0 -show_header 1 tcl::dict::for {cname cdec} [set WEB_colour_map_$g] { $t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec] - if {$cname in $white_fg_list} { - set fg "web-white" - } else { - set fg "web-black" - } + set fg "rgb-$cdec-contrasting" + #if {$cname in $white_fg_list} { + # set fg "web-white" + #} else { + # set fg "web-black" + #} #$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname] } @@ -2083,12 +2256,66 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return $displaytable } + lappend PUNKARGS [list { + @id -id ::punk::ansi::a? + @cmd -name "punk::ansi::a?"\ + -summary\ + "ANSI colour information"\ + -help\ + "" + @form -form "sgr_overview" + @values -form "sgr_overview" -min 0 -max 0 + + + @form -form "term" + @leaders -form "term" -min 1 -max 1 + term -type literal(term) -help\ + "256 term colours" + @opts -min 0 -max 0 + @values -form "term" -min 0 -max -1 + panel -type string -optional 1 -multiple 1 -default {16 main greyscale note}\ + -choices {16 main greyscale pastel rainbow note} + + @form -form "tk" + @leaders -form "tk" -min 1 -max 1 + tk -type literal(tk)|literal(TK) -help\ + "Tk colours" + @opts -form "tk" + -merged -type none -help\ + "If this flag is supplied - show colour names with the same RGB + values together." + @values -form "tk" -min 0 -max -1 + glob -type string -optional 1 -multiple 1 -help\ + "A glob string such as *green*. + Multiple glob entries can be provided. The search is case insensitive" + + + @form -form "web" + @values -form "web" -min 1 -max -1 + web -type literal(web) -help\ + "Web colours" + panel -type string -optional 1 -multiple 1 -choices {basic pink red orange yellow brown purple blue cyan green white gray} + + @form -form "x11" + @values -form "x11" -min 1 -max 1 + x11 -type literal(x11) -help\ + "x11 colours" + + + @form -form "sample" + @values -form "sample" -min 1 -max -1 + colourcode -type sgr|Sgr|literalprefix(term-)|literalprefix(Term-)|literalprefix(web-)|literalprefix(Web-)|literalprefix(rgb)|literalprefix(Rgb)\ + -optional 0\ + -multiple 1 + + }] proc a? {args} { #*** !doctools #[call [fun a?] [opt {ansicode...}]] #[para]Return an ansi string representing a table of codes and a panel showing the colours variable SGR_setting_map variable SGR_colour_map + variable TK_colour_map_lookup set fcposn [lsearch $args "force*"] set fc "" set opt_forcecolour 0 @@ -2172,6 +2399,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append out \n append out "[a+ {*}$fc web-white]X11 colours[a] - mostly match Web colours" \n append out [textblock::join -- $indent "To see differences: a? x11"] \n + append out \n + append out "[a+ {*}$fc web-white]Tk colours[a]" \n + append out [textblock::join -- $indent "To see all 750+ names use: a? tk"] \n + append out [textblock::join -- $indent "Restrict the results using globs e.g a? tk *green* *yellow*"] \n + append out [textblock::join -- $indent "The foreground colour in this table is generated using the contrasting suffix"] \n + append out [textblock::join -- $indent "Example: \[a+ tk-tan-contrasting Tk-tan\]text\[a] -> [a+ {*}$fc tk-tan-contrasting Tk-tan]text[a]"] \n + append out \n + append out "[a+ {*}$fc web-white]Combination testing[a]" \n + append out [textblock::join -- $indent "Example: a? red brightgreen underline Tk-slategrey italic"] \n + append out [textblock::join -- $indent "This will show a small table of each applied code and a RESULT row. The 'red' in this case is redundant,"] \n + append out [textblock::join -- $indent "so a final MERGED row displays with an alert 'REDUNDANCIES FOUND'."] \n + append out [textblock::join -- $indent "The final columns of RESULT and MERGED (showing raw ANSI sequence) will differ if the arguments aren't in canonical order."] \n + append out [textblock::join -- $indent "The MERGED line will only display if there are redundancies or different ordering."] \n + if {[tcl::info::exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { append out \n @@ -2191,40 +2432,74 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { switch -- [lindex $args 0] { term { - set termargs [lrange $args 1 end] - foreach ta $termargs { - switch -- $ta { - pastel - rainbow {} - default {error "unrecognised term option '$ta'. Known values: pastel rainbow"} - } - } - set out "16 basic colours\n" - append out [colourtable_16_names -forcecolour $opt_forcecolour] \n - append out "216 colours\n" - append out [colourtable_216_names -forcecolour $opt_forcecolour] \n - append out "24 greyscale colours\n" - append out [colourtable_24_names -forcecolour $opt_forcecolour] - foreach ta $termargs { - switch -- $ta { + set argd [punk::args::parse $args -form "term" -errorstyle standard withid ::punk::ansi::a?] + lassign [dict values $argd] leaders opts values received + set panels [dict get $values panel] + + set out "" + foreach panel $panels { + #punk::args has already resolved prefixes to full panel names + switch -- $panel { + 16 { + append out "16 basic colours\n" + append out [colourtable_16_names -forcecolour $opt_forcecolour] \n + } + main { + append out "216 colours\n" + append out [colourtable_216_names -forcecolour $opt_forcecolour] \n + } + note { + append out "\nNote: The 256 term colours especially 0-15 may be altered by terminal palette settings or ansi OSC 4 codes, so specific RGB values are unavailable" \n + append out " grey vs gray (UK/US spelling) - these are inconsistent for historical reasons. e.g grey0,lightslategrey,darkslategray1" \n + } + greyscale { + append out "24 greyscale colours\n" + append out [colourtable_24_names -forcecolour $opt_forcecolour] \n + } pastel { - append out \n append out "Pastel Colour Space (punk::ansi::colourtable_term_pastel)\n" - append out [colourtable_term_pastel -forcecolour $opt_forcecolour] + append out [colourtable_term_pastel -forcecolour $opt_forcecolour] \n } rainbow { - append out \n append out "Rainbow Colours (punk::ansi::colourtable_term_rainbow)\n" - append out [colourtable_term_rainbow -forcecolour $opt_forcecolour] + append out [colourtable_term_rainbow -forcecolour $opt_forcecolour] \n + } + default { + #only reachable if punk::args definition is out of sync + set panelnames {16 main greyscale pastel rainbow note} + append out "(ERROR: unrecognised panel '$ta' for 'a? term'. Known values $panelnames)" } } } - append out "\nNote: The 256 term colours especially 0-15 may be altered by terminal palette settings or ansi OSC 4 codes, so specific RGB values are unavailable" return $out } web { - return [colourtable_web -forcecolour $opt_forcecolour -groups [lrange $args 1 end]] + set argd [punk::args::parse $args -form "web" -errorstyle standard withid ::punk::ansi::a?] + lassign [dict values $argd] leaders opts values received + if {[dict exists $received panel]} { + set panels [dict get $values panel] + } else { + set panels {*} + } + return [colourtable_web -forcecolour $opt_forcecolour -groups $panels] + } + tk - TK { + set argd [punk::args::parse $args -form "tk" -errorstyle standard withid ::punk::ansi::a?] + lassign [dict values $argd] leaders opts values received + if {[dict exists $received glob]} { + set globs [dict get $values glob] + } else { + set globs {*} + } + if {[dict exists $received -merged]} { + set ismerged 1 + } else { + set ismerged 0 + } + return [colourtable_tk -merged $ismerged -forcecolour $opt_forcecolour -globs $globs] } x11 { + set argd [punk::args::parse $args -form "x11" -errorstyle standard withid ::punk::ansi::a?] set out "" append out " Mostly same as web - known differences displayed" \n append out [colourtable_x11diff -forcecolour $opt_forcecolour] @@ -2243,10 +2518,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set resultlist [list] foreach i $args { - set f4 [tcl::string::range $i 0 3] + #set f4 [tcl::string::range $i 0 3] + set pfx [lindex [::split $i "-# "] 0] set s [a+ {*}$fc $i]sample - switch -- $f4 { - web- - Web- - WEB- { + switch -- $pfx { + web - Web - WEB { set tail [tcl::string::tolower [tcl::string::trim [tcl::string::range $i 4 end] -]] set cont [string range $tail end-11 end] switch -- $cont { @@ -2275,7 +2551,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu $t add_row [list $i $descr $s [ansistring VIEW $s]] } term - Term - undt { - set tail [tcl::string::trim [tcl::string::range $i 4 end] -] + set tail [tcl::string::range $i 5 end] if {[tcl::string::is integer -strict $tail]} { if {$tail < 256} { set descr "[tcl::dict::get $TERM_colour_map_reverse $tail]" @@ -2292,10 +2568,19 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t add_row [list $i $descr $s [ansistring VIEW $s]] } - x11- - X11- { - set tail [tcl::string::tolower [tcl::string::trim [tcl::string::range $i 4 end] -]] - if {[tcl::dict::exists $X11_colour_map $tail]} { - set dec [tcl::dict::get $X11_colour_map $tail] + x11 - X11 { + set tail [tcl::string::tolower [tcl::string::range $i 4 end]] + set cont [string range $tail end-11 end] + switch -- $cont { + -contrasting - -contrastive { + set cname [string range $tail 0 end-12] + } + default { + set cname $tail + } + } + if {[tcl::dict::exists $X11_colour_map $cname]} { + set dec [tcl::dict::get $X11_colour_map $cname] set hex [colour_dec2hex $dec] set descr "$hex $dec" } else { @@ -2303,12 +2588,27 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t add_row [list $i $descr $s [ansistring VIEW $s]] } - rgb- - Rgb- - RGB- - - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 - - rgb# - Rgb# - RGB# - - und# - und- { + tk - Tk { + set tail [tcl::string::tolower [tcl::string::range $i 3 end]] + set cont [string range $tail end-11 end] + switch -- $cont { + -contrasting - -contrastive { + set cname [string range $tail 0 end-12] + } + default { + set cname $tail + } + } + if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { + set dec [tcl::dict::get $TK_colour_map_lookup $cname] + set hex [colour_dec2hex $dec] + set descr "$hex $dec" + } else { + set descr "UNKNOWN colour for tk" + } + $t add_row [list $i $descr $s [ansistring VIEW $s]] + } + rgb - Rgb - RGB - und { set cont [string range $i end-11 end] switch -- $cont { -contrasting - -contrastive { @@ -2339,7 +2639,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } set info "$hexfinal $decfinal" ;#show opposite type as first line of info col } else { - set tail [tcl::string::trim [tcl::string::range $iplain 3 end] -] + set tail [tcl::string::range $iplain 4 end] set dec $tail switch -- $cont { -contrasting { @@ -2369,15 +2669,23 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend x11colours $c } } + if {[dict exists $::punk::ansi::colourmap::TK_colour_map_reverse $decfinal]} { + set tkcolours [dict get $::punk::ansi::colourmap::TK_colour_map_reverse $decfinal] + } else { + set tkcolours [list] + } foreach c $webcolours { append info \n web-$c } foreach c $x11colours { append info \n x11-$c } + foreach c $tkcolours { + append info \n tk-$c + } $t add_row [list $i "$info" $s [ansistring VIEW $s]] } - unde { + default { switch -- $i { undercurly - undercurl - underdotted - underdot - underdashed - underdash - undersingle - underdouble { $t add_row [list $i extended $s [ansistring VIEW $s]] @@ -2389,19 +2697,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu $t add_row [list $i "SGR 59" $s [ansistring VIEW $s]] } default { - $t add_row [list $i UNKNOWN $s [ansistring VIEW $s]] - } - } - } - default { - if {[tcl::string::is integer -strict $i]} { - set rmap [lreverse $SGR_map] - $t add_row [list $i "SGR [tcl::dict::get $rmap $i]" $s [ansistring VIEW $s]] - } else { - if {[tcl::dict::exists $SGR_map $i]} { - $t add_row [list $i "SGR [tcl::dict::get $SGR_map $i]" $s [ansistring VIEW $s]] - } else { - $t add_row [list $i UNKNOWN $s [ansistring VIEW $s]] + #$t add_row [list $i UNKNOWN $s [ansistring VIEW $s]] + if {[tcl::string::is integer -strict $i]} { + set rmap [lreverse $SGR_map] + $t add_row [list $i "SGR [tcl::dict::get $rmap $i]" $s [ansistring VIEW $s]] + } else { + if {[tcl::dict::exists $SGR_map $i]} { + $t add_row [list $i "SGR [tcl::dict::get $SGR_map $i]" $s [ansistring VIEW $s]] + } else { + $t add_row [list $i UNKNOWN $s [ansistring VIEW $s]] + } + } } } } @@ -2541,9 +2847,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set t [list] set e [list] ;#extended codes needing to go in own escape sequence foreach i $args { - set f4 [tcl::string::range $i 0 3] - switch -- $f4 { - web- { + set pfx [lindex [::split $i "-# "] 0] + #set f4 [tcl::string::range $i 0 3] + switch -- $pfx { + web { #variable WEB_colour_map #upvar ::punk::ansi::WEB_colour_map WEB_colour_map #foreground web colour @@ -2577,7 +2884,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu puts stderr "ansi web colour unmatched: '$i' in call 'a+ $args'" } } - Web- - WEB- { + Web - WEB { #variable WEB_colour_map #upvar ::punk::ansi::WEB_colour_map WEB_colour_map #background web colour @@ -2609,140 +2916,94 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu puts stderr "ansi Web colour unmatched: '$i' in call 'a+ $args'" } } - rese {lappend t 0 ;#reset} + reset {lappend t 0} bold {lappend t 1} dim {lappend t 2} - blin { - #blink - lappend t 5 - } - fast { - #fastblink - lappend t 6 - } - nobl { - #noblink - lappend t 25 - } + blink {lappend t 5} + fastblink {lappend t 6 } + noblink {lappend t 25} hide {lappend t 8} - norm {lappend t 22 ;#normal} - unde { - #TODO - fix - # extended codes with colon suppress normal SGR attributes when in same escape sequence on terminal that don't support the extended codes. - # need to emit in - switch -- $i { - underline { - lappend t 4 ;#underline - } - underlinedefault { - lappend t 59 - } - underextendedoff { - #lremove any existing 4:1 etc - #NOTE struct::set result order can differ depending on whether tcl/critcl imp used - #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] - set e [punk::lib::ldiff $e [list 4:1 4:2 4:3 4:4 4:5]] - lappend e 4:0 - } - undersingle { - lappend e 4:1 - } - underdouble { - lappend e 4:2 - } - undercurly - undercurl { - lappend e 4:3 - } - underdotted - underdot { - lappend e 4:4 - } - underdashed - underdash { - lappend e 4:5 - } - default { - puts stderr "ansi term unmatched: unde* '$i' in call 'a $args' (underline,undersingle,underdouble,undercurly,underdotted,underdashed)" - } - } - } - doub {lappend t 21 ;#doubleunderline} - noun { + normal {lappend t 22} + underline {lappend t 4} + underlinedefault {lappend t 59} + underextendedoff { + #lremove any existing 4:1 etc + #NOTE struct::set result order can differ depending on whether tcl/critcl imp used + #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] + set e [punk::lib::ldiff $e [list 4:1 4:2 4:3 4:4 4:5]] + lappend e 4:0 + } + undersingle { + lappend e 4:1 + } + underdouble { + lappend e 4:2 + } + undercurly - undercurl { + lappend e 4:3 + } + underdotted - underdot { + lappend e 4:4 + } + underdashed - underdash { + #TODO - fix + # extended codes with colon suppress normal SGR attributes when in same escape sequence on terminal that don't support the extended codes. + # need to emit in + lappend e 4:5 + } + doubleunderline {lappend t 21} + nounderline { lappend t 24 ;#nounderline #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] lappend e 4:0 } - stri {lappend t 9 ;#strike} - nost {lappend t 29 ;#nostrike} - ital {lappend t 3 ;#italic} - noit {lappend t 23 ;#noitalic} - reve {lappend t 7 ;#reverse} - nore {lappend t 27 ;#noreverse} - defa { - switch -- $i { - defaultfg { - lappend t 39 - } - defaultbg { - lappend t 49 - } - defaultund { - lappend t 59 - } - default { - puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } - } - } - nohi {lappend t 28 ;#nohide} - over {lappend t 53 ;#overline} - noov {lappend t 55 ;#nooverline} - fram { - if {$i eq "frame"} { - lappend t 51 ;#frame - } else { - lappend t 52 ;#framecircle - } - } - nofr {lappend t 54 ;#noframe} - blac {lappend t 30 ;#black} + strike {lappend t 9} + nostrike {lappend t 29} + italic {lappend t 3} + noitalic {lappend t 23} + reverse {lappend t 7} + noreverse {lappend t 27} + defaultfg {lappend t 39} + defaultbg {lappend t 49} + defaultund {lappend t 59} + nohide {lappend t 28} + overline {lappend t 53} + nooverline {lappend t 55} + frame {lappend t 51} + framecircle {lappend t 52} + noframe {lappend t 54} + black {lappend t 30} red {lappend t 31} - gree {lappend t 32 ;#green} - yell {lappend t 33 ;#yellow} + green {lappend t 32} + yellow {lappend t 33} blue {lappend t 34} - purp {lappend t 35 ;#purple} + purple {lappend t 35} cyan {lappend t 36} - whit {lappend t 37 ;#white} - Blac {lappend t 40 ;#Black} + white {lappend t 37} + Black {lappend t 40} Red {lappend t 41} - Gree {lappend t 42 ;#Green} - Yell {lappend t 43 ;#Yellow} + Green {lappend t 42} + Yellow {lappend t 43} Blue {lappend t 44} - Purp {lappend t 45 ;#Purple} + Purple {lappend t 45} Cyan {lappend t 46} - Whit {lappend t 47 ;#White} - brig { - switch -- $i { - brightblack {lappend t 90} - brightred {lappend t 91} - brightgreen {lappend t 92} - brightyellow {lappend t 93} - brightblue {lappend t 94} - brightpurple {lappend t 95} - brightcyan {lappend t 96} - brightwhite {lappend t 97} - } - } - Brig { - switch -- $i { - Brightblack {lappend t 100} - Brightred {lappend t 101} - Brightgreen {lappend t 102} - Brightyellow {lappend t 103} - Brightblue {lappend t 104} - Brightpurple {lappend t 105} - Brightcyan {lappend t 106} - Brightwhite {lappend t 107} - } - } + White {lappend t 47} + brightblack {lappend t 90} + brightred {lappend t 91} + brightgreen {lappend t 92} + brightyellow {lappend t 93} + brightblue {lappend t 94} + brightpurple {lappend t 95} + brightcyan {lappend t 96} + brightwhite {lappend t 97} + Brightblack {lappend t 100} + Brightred {lappend t 101} + Brightgreen {lappend t 102} + Brightyellow {lappend t 103} + Brightblue {lappend t 104} + Brightpurple {lappend t 105} + Brightcyan {lappend t 106} + Brightwhite {lappend t 107} term { #variable TERM_colour_map #256 colour foreground by Xterm name or by integer @@ -2772,113 +3033,120 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - - Rgb- - RGB- - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 { - #decimal rgb foreground/background - #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx - - set cont [string range $i end-11 end] - switch -- $cont { - -contrasting - -contrastive { - set iplain [string range $i 0 end-12] + rgb - Rgb - RGB { + set utype [string index $i 3] + if {$utype eq "-"} { + #decimal rgb foreground/background + #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx + set cont [string range $i end-11 end] + switch -- $cont { + -contrasting - -contrastive { + set iplain [string range $i 0 end-12] + } + default { + set iplain $i + } } - default { - set iplain $i + set rgbspec [tcl::string::range $iplain 4 end] + set RGB [tcl::string::map [list - { } , { } {;} { }] $rgbspec] ;#RGB as list + switch -- $cont { + -contrasting { + set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {;}] + } + -contrastive { + set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {;}] + } + default { + set rgbfinal [join $RGB {;}] + } } - } - set rgbspec [tcl::string::trim [tcl::string::range $iplain 3 end] -] - set RGB [tcl::string::map [list - { } , { } {;} { }] $rgbspec] ;#RGB as list - switch -- $cont { - -contrasting { - set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {;}] + if {[tcl::string::index $i 0] eq "r"} { + #fg + lappend t "38;2;$rgbfinal" + } else { + #bg + lappend t "48;2;$rgbfinal" } - -contrastive { - set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {;}] + + } elseif {$utype eq "#"} { + set hex6 [tcl::string::range $i 4 end] + #set rgb [join [::scan $hex6 %2X%2X%2X] {;}] + set RGB [::scan $hex6 %2X%2X%2X] + set cont [string range $i end-11 end] + switch -- $cont { + -contrasting { + set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {;}] + } + -contrastive { + set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {;}] + } + default { + set rgbfinal [join $RGB {;}] + } } - default { - set rgbfinal [join $RGB {;}] + if {[tcl::string::index $i 0] eq "r"} { + #hex rgb foreground + lappend t "38;2;$rgbfinal" + } else { + #hex rgb background + lappend t "48;2;$rgbfinal" } - } - if {[tcl::string::index $i 0] eq "r"} { - #fg - lappend t "38;2;$rgbfinal" } else { - #bg - lappend t "48;2;$rgbfinal" + puts stderr "punk::ansi::a+ ansi term rgb colour unmatched: '$i' in call 'a+ $args'" } } - "rgb#" - "Rgb#" - "RGB#" { - set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] - #set rgb [join [::scan $hex6 %2X%2X%2X] {;}] - set RGB [::scan $hex6 %2X%2X%2X] - set cont [string range $i end-11 end] - switch -- $cont { - -contrasting { - set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {;}] - } - -contrastive { - set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {;}] + und { + set utype [string index $i 3] + if {$utype eq "-"} { + #decimal rgb underline + #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx + #https://wezfurlong.org/wezterm/escape-sequences.html#csi-582-underline-color-rgb + set rgbspec [tcl::string::range $i 4 end] + set RGB [lrange [tcl::string::map [list - { } , { } {;} { }] $rgbspec] 0 2] + #puts "---->'$RGB'<----" + set cont [string range $i end-11 end] + switch -- $cont { + -contrasting { + set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {:}] + } + -contrastive { + set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {:}] + } + default { + set rgbfinal [join $RGB {:}] + } } - default { - set rgbfinal [join $RGB {;}] + #lappend e "58:2:$rgbfinal" ;# - no colorspace ID - some terminals support? which? + lappend e "58:2::$rgbfinal" + } elseif {$utype eq "#"} { + #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + set hex6 [tcl::string::range $i 4 end] + #set rgb [join [::scan $hex6 %2X%2X%2X] {:}] + set RGB [::scan $hex6 %2X%2X%2X] + set cont [string range $i end-11 end] + switch -- $cont { + -contrasting { + set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {:}] + } + -contrastive { + set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {:}] + } + default { + set rgbfinal [join $RGB {:}] + } } - } - if {[tcl::string::index $i 0] eq "r"} { - #hex rgb foreground - lappend t "38;2;$rgbfinal" + lappend e "58:2::$rgbfinal" } else { - #hex rgb background - lappend t "48;2;$rgbfinal" + puts stderr "punk::ansi::a+ ansi term underline colour unmatched: '$i' in call 'a+ $args'" } } - und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx - #https://wezfurlong.org/wezterm/escape-sequences.html#csi-582-underline-color-rgb - set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] - set RGB [lrange [tcl::string::map [list - { } , { } {;} { }] $rgbspec] 0 2] - #puts "---->'$RGB'<----" - set cont [string range $i end-11 end] - switch -- $cont { - -contrasting { - set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {:}] - } - -contrastive { - set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {:}] - } - default { - set rgbfinal [join $RGB {:}] - } - } - #lappend e "58:2:$rgbfinal" ;# - no colorspace ID - some terminals support? which? - lappend e "58:2::$rgbfinal" - } - "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators - set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] - #set rgb [join [::scan $hex6 %2X%2X%2X] {:}] - set RGB [::scan $hex6 %2X%2X%2X] - set cont [string range $i end-11 end] - switch -- $cont { - -contrasting { - set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {:}] - } - -contrastive { - set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {:}] - } - default { - set rgbfinal [join $RGB {:}] - } - } - lappend e "58:2::$rgbfinal" - } undt { #CSI 58:5 UNDERLINE COLOR PALETTE INDEX #CSI 58 : 5 : INDEX m #variable TERM_colour_map #256 colour underline by Xterm name or by integer #name is xterm name or colour index from 0 - 255 - set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] + set cc [tcl::string::tolower [tcl::string::range $i 5 end]] if {[tcl::string::is integer -strict $cc] & $cc < 256} { lappend e "58:5:$cc" } else { @@ -2889,7 +3157,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - x11- { + x11 { variable X11_colour_map #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] @@ -2898,10 +3166,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { - puts stderr "ansi x11 colour unmatched: '$i' in call 'a+ $args'" + puts stderr "ansi x11 foreground colour unmatched: '$i' in call 'a+ $args'" } } - X11- { + X11 { variable X11_colour_map #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] @@ -2910,7 +3178,71 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { - puts stderr "ansi X11 colour unmatched: '$i'" + puts stderr "ansi X11 background colour unmatched: '$i'" + } + } + tk { + #foreground tk names + variable TK_colour_map_lookup ;#use the dict with added lowercase versions + set tail [tcl::string::tolower [tcl::string::range $i 3 end]] + set cont [string range $tail end-11 end] + switch -- $cont { + -contrasting - -contrastive { + set cname [string range $tail 0 end-12] + } + default { + set cname $tail + } + } + + if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { + set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname] + switch -- $cont { + -contrasting { + set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] + } + -contrastive { + set rgb [join [lindex [punk::ansi::colour::contrast_pair {*}[split $rgbdash -]] 0] {;}] + } + default { + set rgb [tcl::string::map { - ;} $rgbdash] + } + } + lappend t "38;2;$rgb" + } else { + puts stderr "ansi tk foreground colour unmatched: '$i' in call 'a+ $args'" + } + } + Tk - TK { + #background X11 names + variable TK_colour_map_lookup ;#with lc versions + set tail [tcl::string::tolower [tcl::string::range $i 3 end]] + set cont [string range $tail end-11 end] + switch -- $cont { + -contrasting - -contrastive { + set cname [string range $tail 0 end-12] + } + default { + set cname $tail + } + } + #set cname [tcl::string::tolower [tcl::string::range $i 3 end]] + if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { + set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname] + switch -- $cont { + -contrasting { + set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] + } + -contrastive { + set rgb [join [lindex [punk::ansi::colour::contrast_pair {*}[split $rgbdash -]] 0] {;}] + } + default { + set rgb [tcl::string::map { - ;} $rgbdash] + } + } + lappend t "48;2;$rgb" + } else { + puts stderr "ansi Tk background colour unmatched: '$i'" } } default { @@ -2919,7 +3251,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } elseif {[tcl::string::first : $i] > 0} { lappend e $i } else { - puts stderr "ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" + puts stderr "punk::ansi::a+ ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" } } } @@ -2974,6 +3306,32 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #indent of 1 space is important for clarity in i -return string a+ output dict set SGR_samples $k " [punk::ansi::a+ $k]sample\x1b\[m" } + set SGR_help\ + {SGR code from the list below, or an integer corresponding to the code e.g 31 = red. + A leading capital letter indicates a codename applies to the background colour. + Other accepted codes are: + term- Term- foreground/background where int is 0-255 terminal color + term- Term- foreground/background + + web- Web- + + x11- X11- + + tk- Tk- + + rgb--- Rgb--- foreground/background where are the + 0-255 int values for red, green and blue. + rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 + + The acceptable values for colours can be queried using + punk::ansi::a? term + punk::ansi::a? web + punk::ansi::a? x11 + punk::ansi::a? tk + + Example to set foreground red and background cyan followed by a reset: + set str \"[a+ red Cyan]sample text[a]\" + } lappend PUNKARGS [list { @id -id ::punk::ansi::a+ @cmd -name "punk::ansi::a+" -help\ @@ -2981,28 +3339,25 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu Unlike punk::ansi::a - it is not prefixed with an ANSI reset. " @values -min 0 -max -1 - } [string map [list [dict keys $SGR_map] $SGR_samples] { - code -type string -optional 1 -multiple 1 -choices {}\ - -choicelabels {}\ + } [string map [list %choices% [dict keys $SGR_map] %choicelabels% $SGR_samples %SGR_help% $SGR_help] { + code -type string -optional 1 -multiple 1 -choices {%choices%}\ + -choicelabels {%choicelabels%}\ -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ - "SGR code from the list below, or an integer corresponding to the code e.g 31 = red. - A leading capital letter indicates a codename applies to the background colour. - Other accepted codes are: - term- Term- foreground/background where int is 0-255 terminal color - term- Term- foreground/background - rgb--- Rgb--- foreground/background where are the - 0-255 int values for red, green and blue. - rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 - web- Web- - - The acceptable values for and can be queried using - punk::ansi::a? term - and - punk::ansi::a? web - - Example to set foreground red and background cyan followed by a reset: - set str \"[a+ red Cyan]sample text[a]\" + "%SGR_help%" + }]] + + lappend PUNKARGS [list { + @id -id ::punk::ansi::a + @cmd -name "punk::ansi::a" -help\ + "Returns an ANSI sgr escape sequence based on the list of supplied codes. + Unlike punk::ansi::a+ - it is prefixed with an ANSI reset. " + @values -min 0 -max -1 + } [string map [list %choices% [dict keys $SGR_map] %choicelabels% $SGR_samples %SGR_help% $SGR_help] { + code -type string -optional 1 -multiple 1 -choices {%choices%}\ + -choicelabels {%choicelabels%}\ + -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ + "%SGR_help%" }]] proc a {args} { @@ -3027,6 +3382,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #we want this to be available to call even if ansi is off variable WEB_colour_map variable TERM_colour_map + variable TK_colour_map_lookup ;#Tk accepts lowercase versions of colours even though some colours are documented with casing set colour_disabled 0 #whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache -action clear @@ -3044,9 +3400,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set t [list] set e [list] ;#extended codes will suppress standard SGR colours and attributes if merged in same escape sequence foreach i $args { - set f4 [tcl::string::range $i 0 3] - switch -- $f4 { - web- { + #set f4 [tcl::string::range $i 0 3] + set pfx [lindex [split $i "-# "] 0] + switch -- $pfx { + web { #variable WEB_colour_map #upvar ::punk::ansi::WEB_colour_map WEB_colour_map #foreground web colour @@ -3059,7 +3416,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu puts stderr "ansi web colour unmatched: '$i' in call 'a $args'" } } - Web- - WEB- { + Web - WEB { #variable WEB_colour_map #upvar ::punk::ansi::WEB_colour_map WEB_colour_map #background web colour @@ -3070,142 +3427,100 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu puts stderr "ansi Web colour unmatched: '$i' in call 'a $args'" } } - rese {lappend t 0 ;#reset} + reset {lappend t 0} bold {lappend t 1} dim {lappend t 2} - blin { - #blink - lappend t 5 - } - fast { - #fastblink - lappend t 6 - } - nobl { - #noblink - lappend t 25 - } + blink {lappend t 5} + fastblink {lappend t 6} + noblink {lappend t 25} hide {lappend t 8} - norm {lappend t 22 ;#normal} - unde { - switch -- $i { - underline { - lappend t 4 ;#underline - } - underlinedefault { - lappend t 59 - } - underextendedoff { - #lremove any existing 4:1 etc - #use of struct::set with critcl is fast, but will reorder e (with differences depending on tcl vs critcl) - #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] - set e [punk::lib::ldiff $e [list 4:1 4:2 4:3 4:4 4:5]] - lappend e 4:0 - } - undersingle { - lappend e 4:1 - } - underdouble { - lappend e 4:2 - } - undercurly - undercurl { - lappend e 4:3 - } - underdotted - underdot { - lappend e 4:4 - } - underdashed - underdash { - lappend e 4:5 - } - default { - puts stderr "ansi term unmatched: unde* '$i' in call 'a $args' (underline,undersingle,underdouble,undercurly,underdotted,underdashed)" - } - } - } - doub {lappend t 21 ;#doubleunderline} - noun { + normal {lappend t 22} + underline { + lappend t 4 ;#underline + } + underlinedefault {lappend t 59} + underextendedoff { + #lremove any existing 4:1 etc + #use of struct::set with critcl is fast, but will reorder e (with differences depending on tcl vs critcl) + #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] + set e [punk::lib::ldiff $e [list 4:1 4:2 4:3 4:4 4:5]] + lappend e 4:0 + } + undersingle { + lappend e 4:1 + } + underdouble { + lappend e 4:2 + } + undercurly - undercurl { + lappend e 4:3 + } + underdotted - underdot { + lappend e 4:4 + } + underdashed - underdash { + lappend e 4:5 + } + doubleunderline {lappend t 21} + nounderline { lappend t 24 ;#nounderline #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] lappend e 4:0 } - stri {lappend t 9 ;#strike} - nost {lappend t 29 ;#nostrike} - ital {lappend t 3 ;#italic} - noit {lappend t 23 ;#noitalic} - reve {lappend t 7 ;#reverse} - nore {lappend t 27 ;#noreverse} - defa { - switch -- $i { - defaultfg { - lappend t 39 - } - defaultbg { - lappend t 49 - } - defaultund { - lappend t 59 - } - default { - puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } - } - } - nohi {lappend t 28 ;#nohide} - over {lappend t 53 ;#overline} - noov {lappend t 55 ;#nooverline} - fram { - if {$i eq "frame"} { - lappend t 51 ;#frame - } else { - lappend t 52 ;#framecircle - } - } - nofr {lappend t 54 ;#noframe} - blac {lappend t 30 ;#black} + strike {lappend t 9} + nostrike {lappend t 29} + italic {lappend t 3} + noitalic {lappend t 23} + reverse {lappend t 7} + noreverse {lappend t 27} + defaultfg {lappend t 39} + defaultbg {lappend t 49} + defaultund { + lappend t 59 + } + nohide {lappend t 28} + overline {lappend t 53} + nooverline {lappend t 55} + frame {lappend t 51} + framecircle {lappend t 52} + noframe {lappend t 54} + black {lappend t 30} red {lappend t 31} - gree {lappend t 32 ;#green} - yell {lappend t 33 ;#yellow} + green {lappend t 32} + yellow {lappend t 33} blue {lappend t 34} - purp {lappend t 35 ;#purple} + purple {lappend t 35} cyan {lappend t 36} - whit {lappend t 37 ;#white} - Blac {lappend t 40 ;#Black} + white {lappend t 37} + Black {lappend t 40} Red {lappend t 41} - Gree {lappend t 42 ;#Green} - Yell {lappend t 43 ;#Yellow} + Green {lappend t 42} + Yellow {lappend t 43} Blue {lappend t 44} - Purp {lappend t 45 ;#Purple} + Purple {lappend t 45} Cyan {lappend t 46} - Whit {lappend t 47 ;#White} - brig { - switch -- $i { - brightblack {lappend t 90} - brightred {lappend t 91} - brightgreen {lappend t 92} - brightyellow {lappend t 93} - brightblue {lappend t 94} - brightpurple {lappend t 95} - brightcyan {lappend t 96} - brightwhite {lappend t 97} - } - } - Brig { - switch -- $i { - Brightblack {lappend t 100} - Brightred {lappend t 101} - Brightgreen {lappend t 102} - Brightyellow {lappend t 103} - Brightblue {lappend t 104} - Brightpurple {lappend t 105} - Brightcyan {lappend t 106} - Brightwhite {lappend t 107} - } - } + White {lappend t 47} + brightblack {lappend t 90} + brightred {lappend t 91} + brightgreen {lappend t 92} + brightyellow {lappend t 93} + brightblue {lappend t 94} + brightpurple {lappend t 95} + brightcyan {lappend t 96} + brightwhite {lappend t 97} + Brightblack {lappend t 100} + Brightred {lappend t 101} + Brightgreen {lappend t 102} + Brightyellow {lappend t 103} + Brightblue {lappend t 104} + Brightpurple {lappend t 105} + Brightcyan {lappend t 106} + Brightwhite {lappend t 107} term { #variable TERM_colour_map #256 colour foreground by Xterm name or by integer #name is xterm name or colour index from 0 - 255 - set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] + set cc [tcl::string::tolower [tcl::string::range $i 5 end]] if {[tcl::string::is integer -strict $cc] & $cc < 256} { lappend t "38;5;$cc" } else { @@ -3219,7 +3534,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu Term - TERM { #variable TERM_colour_map #256 colour background by Xterm name or by integer - set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] + set cc [tcl::string::tolower [tcl::string::range $i 5 end]] if {[tcl::string::is integer -strict $cc] && $cc < 256} { lappend t "48;5;$cc" } else { @@ -3230,49 +3545,63 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 { - #decimal rgb foreground - #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx - set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] - set rgb [tcl::string::map [list - {;} , {;}] $rgbspec] - lappend t "38;2;$rgb" - } - Rgb- - RGB- - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 { - #decimal rgb background - set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] - set rgb [tcl::string::map [list - {;} , {;}] $rgbspec] - lappend t "48;2;$rgb" - } - "rgb#" { - #hex rgb foreground - set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] - set rgb [join [::scan $hex6 %2X%2X%2X] {;}] - lappend t "38;2;$rgb" - } - "Rgb#" - "RGB#" { - #hex rgb background - set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] - set rgb [join [::scan $hex6 %2X%2X%2X] {;}] - lappend t "48;2;$rgb" - } - und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx - set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] - set rgb [tcl::string::map [list - {:} , {:}] $rgbspec] - lappend e "58:2::$rgb" - } - "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators - set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] - set rgb [join [::scan $hex6 %2X%2X%2X] {:}] - lappend e "58:2::$rgb" + rgb { + set utype [string index $i 3] + if {$utype eq "-"} { + #decimal rgb foreground + #form: rgb-xxx-xxx-xxx + set rgbspec [tcl::string::range $i 4 end] + set rgb [tcl::string::map [list - {;} , {;}] $rgbspec] + lappend t "38;2;$rgb" + } elseif {$utype eq "#"} { + #hex rgb foreground + set hex6 [tcl::string::range $i 4 end] + set rgb [join [::scan $hex6 %2X%2X%2X] {;}] + lappend t "38;2;$rgb" + } else { + puts stderr "ansi rgb foreground colour unmatched: '$i' in call 'a $args'" + } + } + Rgb - RGB { + set utype [string index $i 3] + if {$utype eq "-"} { + #decimal rgb background + set rgbspec [tcl::string::range $i 4 end] + set rgb [tcl::string::map [list - {;} , {;}] $rgbspec] + lappend t "48;2;$rgb" + } elseif {$utype eq "#"} { + #hex rgb background + set hex6 [tcl::string::range $i 4 end] + set rgb [join [::scan $hex6 %2X%2X%2X] {;}] + lappend t "48;2;$rgb" + } else { + puts stderr "ansi Rgb background colour unmatched: '$i' in call 'a $args'" + } + } + und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 {} + und { + set utype [string index $i 3] + if {$utype eq "-"} { + #decimal rgb underline + #form: und-xxx-xxx-xxx + set rgbspec [tcl::string::range $i 4 end] + set rgb [tcl::string::map [list - {:} , {:}] $rgbspec] + lappend e "58:2::$rgb" + } elseif {$utype eq "#"} { + #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + set hex6 [tcl::string::range $i 4 end] + set rgb [join [::scan $hex6 %2X%2X%2X] {:}] + lappend e "58:2::$rgb" + } else { + puts stderr "ansi underline colour unmatched: '$i' in call 'a $args'" + } } undt { #variable TERM_colour_map #256 colour underline by Xterm name or by integer #name is xterm name or colour index from 0 - 255 - set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] + #undt-<0-255> or undt- + set cc [tcl::string::tolower [tcl::string::range $i 5 end]] if {[tcl::string::is integer -strict $cc] & $cc < 256} { lappend e "58:5:$cc" } else { @@ -3283,7 +3612,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - x11- { + x11 { variable X11_colour_map #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] @@ -3292,10 +3621,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { - puts stderr "ansi x11 colour unmatched: '$i'" + puts stderr "ansi x11 foreground colour unmatched: '$i'" } } - X11- { + X11 { variable X11_colour_map #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] @@ -3304,7 +3633,31 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { - puts stderr "ansi X11 colour unmatched: '$i'" + puts stderr "ansi X11 background colour unmatched: '$i'" + } + } + tk { + variable TK_colour_map_lookup + #foreground tk names + set cname [tcl::string::tolower [tcl::string::range $i 3 end]] + if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { + set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname] + set rgb [tcl::string::map [list - {;}] $rgbdash] + lappend t "38;2;$rgb" + } else { + puts stderr "ansi tk foreground colour unmatched: '$i'" + } + } + Tk - TK { + variable TK_colour_map_lookup + #background X11 names + set cname [tcl::string::tolower [tcl::string::range $i 3 end]] + if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { + set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname] + set rgb [tcl::string::map [list - {;}] $rgbdash] + lappend t "48;2;$rgb" + } else { + puts stderr "ansi Tk background colour unmatched: '$i'" } } default { @@ -3313,7 +3666,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } elseif {[tcl::string::first : $i] > 0} { lappend e $i } else { - puts stderr "ansi name unmatched: '$i' in call 'a $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" + puts stderr "punk::ansi::a ansi name unmatched: '$i' in call 'a $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" } } } @@ -3356,7 +3709,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend PUNKARGS [list { @id -id ::punk::ansi::ansiwrap - @cmd -name punk::ansi::ansiwrap -help\ + @cmd -name punk::ansi::ansiwrap\ + -summary\ + "Wrap a string with ANSI codes applied when not overridden by ANSI in the source string."\ + -help\ {Wrap a string with ANSI codes from supplied codelist(s) followed by trailing ANSI reset. The wrapping is done such that @@ -3400,7 +3756,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu -overridecodes -type list -default {} -rawoverrides -type ansi -default "" @values -min 1 -max 1 - text -type string -help\ + text -type any -help\ "String to wrap with ANSI (SGR)" }] proc ansiwrap {args} { @@ -4481,6 +4837,20 @@ to 223 (=255 - 32) } #ever so slightly slower on short strings - much faster than split_at_codes version for large/complex ansi blocks + lappend PUNKARGS [list { + @id -id ::punk::ansi::ansistrip + @cmd -name punk::ansi::ansistrip\ + -summary\ + "Strip ANSI codes and convert VT100 graphics to unicode equivalents."\ + -help\ + "Returns a string with ANSI codes such as SGR, movements etc stripped out. + Alternate graphics chars (VT100 graphics) are replaced with modern unicode + equivalents (e.g boxdrawing glyphs). + PM, APC, SOS contents are stripped - whether or not such wrapped strings + are displayed on various terminals." + @values -min 1 -max 1 + text -type string + }] proc ansistrip {text} { #*** !doctools #[call [fun ansistrip] [arg text] ] @@ -7586,7 +7956,7 @@ tcl::namespace::eval punk::ansi::ansistring { #return pair of column extents occupied by the character index supplied. #single-width grapheme will return pair of integers of equal value - #doulbe-width grapheme will return a pair of consecutive indices + #double-width grapheme will return a pair of consecutive indices proc INDEXCOLUMNS {string idx} { #There is an index per grapheme - whether it is 1 or 2 columns wide set index [lindex [INDEXABSOLUTE $string $idx] 0] @@ -7755,6 +8125,31 @@ namespace eval punk::ansi::colour { } punk::assertion::active on + + #see also the tk function + #winfo rgb . |#XXXXXX|#XXX + #(example in punk::ansi::colourmap::get_rgb_using_tk) + + #proc percent2rgb {n} { + # # map 0..100 to a red-yellow-green sequence + # set n [expr {$n < 0? 0: $n > 100? 100: $n}] + # set red [expr {$n > 75? 60 - ($n * 15 / 25) : 15}] + # set green [expr {$n < 50? $n * 15 / 50 : 15}] + # format "#%01x%01x0" $red $green + #} ;#courtesy of RS (from tcl wiki) + proc percent2#rgb {n} { + # map 0..100 to a red-yellow-green sequence + set n [expr {$n < 0? 0: $n > 100? 100: $n}] + set red [expr {$n > 75? 1020 - ($n * 255 / 25) : 255}] + set green [expr {$n < 50? $n * 255 / 50 : 255}] + format "#%02x%02x00" $red $green + } + + proc random#rgb {} { + format #%06x [expr {int(rand() * 0xFFFFFF)}] + } + + #see also colors package #https://sourceforge.net/p/irrational-numbers/code/HEAD/tree/pkgs/Colors/trunk/colors.tcl#l159 diff --git a/src/modules/punk/ansi/colourmap-999999.0a1.0.tm b/src/modules/punk/ansi/colourmap-999999.0a1.0.tm new file mode 100644 index 00000000..72e526c8 --- /dev/null +++ b/src/modules/punk/ansi/colourmap-999999.0a1.0.tm @@ -0,0 +1,969 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application ::punk::ansi::colourmap 999999.0a1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_::punk::ansi::colourmap 0 999999.0a1.0] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require ::punk::ansi::colourmap] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of ::punk::ansi::colourmap +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by ::punk::ansi::colourmap +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +tcl::namespace::eval ::punk::ansi::colourmap { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace ::punk::ansi::colourmap}] + #[para] Core API functions for ::punk::ansi::colourmap + #[list_begin definitions] + + variable PUNKARGS + + #---------------------------------------------- + #todo - document vars as part of package API + #- or provide a function to return varnames? + #- or wrap each in a function and see if any performance/memory impact? (readonly - so should just be a reference without any copying?) + #TK_colour_map + #TK_colour_map_lookup + #TK_colour_map_merge + #TK_colour_map_reverse + #---------------------------------------------- + + + + #significantly slower than tables - but here as a check/test + lappend PUNKARGS [list { + @id -id ::punk::ansi::colourmap::get_rgb_using_tk + @cmd -name punk::ansi::colourmap::get_rgb_using_tk -help\ + "This function requires Tk to function, and will call + 'package require tk' to load it. + The name argument accepts Tk colour names or hex values + in either #XXX or #XXXXXX format. + Tk colour names can be displayed using the command: + punk::ansi::a? tk ?glob..? + + get_rgb_using_tk returns a decimal rgb string delimited with dashes. + e.g + get_rgb_using_tk #FFF + 255-255-255 + get_rgb_using_tk SlateBlue + 106-90-205" + @leaders + name -type string|stringstartswith(#) + }] + proc get_rgb_using_tk {name} { + package require tk + #assuming 'winfo depth .' is always 32 ? + set RGB [winfo rgb . $name] + set rgb [lmap n $RGB {expr {$n / 256}}] + return [join $rgb -] + } + + variable TK_colour_map + tcl::dict::set TK_colour_map "alice blue" 240-248-255 + tcl::dict::set TK_colour_map AliceBlue 240-248-255 + tcl::dict::set TK_colour_map "antique white" 250-235-215 + tcl::dict::set TK_colour_map AntiqueWhite 250-235-215 + tcl::dict::set TK_colour_map AntiqueWhite1 255-239-219 + tcl::dict::set TK_colour_map AntiqueWhite2 238-223-204 + tcl::dict::set TK_colour_map AntiqueWhite3 205-192-176 + tcl::dict::set TK_colour_map AntiqueWhite4 139-131-120 + tcl::dict::set TK_colour_map aqua 0-255-255 + tcl::dict::set TK_colour_map aquamarine 127-255-212 + tcl::dict::set TK_colour_map aquamarine1 127-255-212 + tcl::dict::set TK_colour_map aquamarine2 118-238-198 + tcl::dict::set TK_colour_map aquamarine3 102-205-170 + tcl::dict::set TK_colour_map aquamarine4 69-139-16 + tcl::dict::set TK_colour_map azure 240-255-255 + tcl::dict::set TK_colour_map azure1 240-255-255 + tcl::dict::set TK_colour_map azure2 224-238-238 + tcl::dict::set TK_colour_map azure3 193-205-205 + tcl::dict::set TK_colour_map azure4 131-139-139 + tcl::dict::set TK_colour_map beige 245-245-220 + tcl::dict::set TK_colour_map bisque 255-228-196 + tcl::dict::set TK_colour_map bisque1 255-228-196 + tcl::dict::set TK_colour_map bisque2 238-213-183 + tcl::dict::set TK_colour_map bisque3 205-183-158 + tcl::dict::set TK_colour_map bisque4 139-125-107 + tcl::dict::set TK_colour_map black 0-0-0 + tcl::dict::set TK_colour_map "blanched almond" 255-235-205 + tcl::dict::set TK_colour_map BlanchedAlmond 255-235-205 + tcl::dict::set TK_colour_map blue 0-0-255 + tcl::dict::set TK_colour_map "blue violet" 138-43-226 + tcl::dict::set TK_colour_map blue1 0-0-255 + tcl::dict::set TK_colour_map blue2 0-0-238 + tcl::dict::set TK_colour_map blue3 0-0-205 + tcl::dict::set TK_colour_map blue4 0-0-139 + tcl::dict::set TK_colour_map BlueViolet 138-43-226 + tcl::dict::set TK_colour_map brown 165-42-42 + tcl::dict::set TK_colour_map brown1 255-64-64 + tcl::dict::set TK_colour_map brown2 238-59-59 + tcl::dict::set TK_colour_map brown3 205-51-51 + tcl::dict::set TK_colour_map brown4 139-35-35 + tcl::dict::set TK_colour_map burlywood 222-184-135 + tcl::dict::set TK_colour_map burlywood1 255-211-155 + tcl::dict::set TK_colour_map burlywood2 238-197-145 + tcl::dict::set TK_colour_map burlywood3 205-170-125 + tcl::dict::set TK_colour_map burlywood4 139-115-85 + tcl::dict::set TK_colour_map "cadet blue" 95-158-160 + tcl::dict::set TK_colour_map CadetBlue 95-158-160 + tcl::dict::set TK_colour_map CadetBlue1 152-245-255 + tcl::dict::set TK_colour_map CadetBlue2 142-229-238 + tcl::dict::set TK_colour_map CadetBlue3 122-197-205 + tcl::dict::set TK_colour_map CadetBlue4 83-134-139 + tcl::dict::set TK_colour_map chartreuse 127-255-0 + tcl::dict::set TK_colour_map chartreuse1 127-255-0 + tcl::dict::set TK_colour_map chartreuse2 118-238-0 + tcl::dict::set TK_colour_map chartreuse3 102-205-0 + tcl::dict::set TK_colour_map chartreuse4 69-139-0 + tcl::dict::set TK_colour_map chocolate 210-105-30 + tcl::dict::set TK_colour_map chocolate1 255-127-36 + tcl::dict::set TK_colour_map chocolate2 238-118-33 + tcl::dict::set TK_colour_map chocolate3 205-102-29 + tcl::dict::set TK_colour_map chocolate4 139-69-19 + tcl::dict::set TK_colour_map coral 255-127-80 + tcl::dict::set TK_colour_map coral1 255-114-86 + tcl::dict::set TK_colour_map coral2 238-106-80 + tcl::dict::set TK_colour_map coral3 205-91-69 + tcl::dict::set TK_colour_map coral4 139-62-47 + tcl::dict::set TK_colour_map "cornflower blue" 100-149-237 + tcl::dict::set TK_colour_map CornflowerBlue 100-149-237 + tcl::dict::set TK_colour_map cornsilk 255-248-220 + tcl::dict::set TK_colour_map cornsilk1 255-248-220 + tcl::dict::set TK_colour_map cornsilk2 238-232-205 + tcl::dict::set TK_colour_map cornsilk3 205-200-177 + tcl::dict::set TK_colour_map cornsilk4 139-136-120 + tcl::dict::set TK_colour_map crimson 220-20-60 + tcl::dict::set TK_colour_map cyan 0-255-255 + tcl::dict::set TK_colour_map cyan1 0-255-255 + tcl::dict::set TK_colour_map cyan2 0-238-238 + tcl::dict::set TK_colour_map cyan3 0-205-205 + tcl::dict::set TK_colour_map cyan4 0-139-139 + tcl::dict::set TK_colour_map "dark blue" 0-0-139 + tcl::dict::set TK_colour_map "dark cyan" 0-139-139 + tcl::dict::set TK_colour_map "dark goldenrod" 184-134-11 + tcl::dict::set TK_colour_map "dark gray" 169-169-169 + tcl::dict::set TK_colour_map "dark green" 0-100-0 + tcl::dict::set TK_colour_map "dark grey" 169-169-169 + tcl::dict::set TK_colour_map "dark khaki" 189-183-107 + tcl::dict::set TK_colour_map "dark magenta" 139-0-139 + tcl::dict::set TK_colour_map "dark olive green" 85-107-47 + tcl::dict::set TK_colour_map "dark orange" 255-140-0 + tcl::dict::set TK_colour_map "dark orchid" 153-50-204 + tcl::dict::set TK_colour_map "dark red" 139-0-0 + tcl::dict::set TK_colour_map "dark salmon" 233-150-122 + tcl::dict::set TK_colour_map "dark sea green" 143-188-143 + tcl::dict::set TK_colour_map "dark slate blue" 72-61-139 + tcl::dict::set TK_colour_map "dark slate gray" 47-79-79 + tcl::dict::set TK_colour_map "dark slate grey" 47-79-79 + tcl::dict::set TK_colour_map "dark turquoise" 0-206-209 + tcl::dict::set TK_colour_map "dark violet" 148-0-211 + tcl::dict::set TK_colour_map DarkBlue 0-0-139 + tcl::dict::set TK_colour_map DarkCyan 0-139-139 + tcl::dict::set TK_colour_map DarkGoldenrod 184-134-11 + tcl::dict::set TK_colour_map DarkGoldenrod1 255-185-15 + tcl::dict::set TK_colour_map DarkGoldenrod2 238-173-14 + tcl::dict::set TK_colour_map DarkGoldenrod3 205-149-12 + tcl::dict::set TK_colour_map DarkGoldenrod4 139-101-8 + tcl::dict::set TK_colour_map DarkGray 169-169-169 + tcl::dict::set TK_colour_map DarkGreen 0-100-0 + tcl::dict::set TK_colour_map DarkGrey 169-169-169 + tcl::dict::set TK_colour_map DarkKhaki 189-183-107 + tcl::dict::set TK_colour_map DarkMagenta 139-0-139 + tcl::dict::set TK_colour_map DarkOliveGreen 85-107-47 + tcl::dict::set TK_colour_map DarkOliveGreen1 202-255-112 + tcl::dict::set TK_colour_map DarkOliveGreen2 188-238-104 + tcl::dict::set TK_colour_map DarkOliveGreen3 162-205-90 + tcl::dict::set TK_colour_map DarkOliveGreen4 110-139-61 + tcl::dict::set TK_colour_map DarkOrange 255-140-0 + tcl::dict::set TK_colour_map DarkOrange1 255-127-0 + tcl::dict::set TK_colour_map DarkOrange2 238-118-0 + tcl::dict::set TK_colour_map DarkOrange3 205-102-0 + tcl::dict::set TK_colour_map DarkOrange4 139-69-0 + tcl::dict::set TK_colour_map DarkOrchid 153-50-204 + tcl::dict::set TK_colour_map DarkOrchid1 191-62-255 + tcl::dict::set TK_colour_map DarkOrchid2 178-58-238 + tcl::dict::set TK_colour_map DarkOrchid3 154-50-205 + tcl::dict::set TK_colour_map DarkOrchid4 104-34-139 + tcl::dict::set TK_colour_map DarkRed 139-0-0 + tcl::dict::set TK_colour_map DarkSalmon 233-150-122 + tcl::dict::set TK_colour_map DarkSeaGreen 43-188-143 + tcl::dict::set TK_colour_map DarkSeaGreen1 193-255-193 + tcl::dict::set TK_colour_map DarkSeaGreen2 180-238-180 + tcl::dict::set TK_colour_map DarkSeaGreen3 155-205-155 + tcl::dict::set TK_colour_map DarkSeaGreen4 105-139-105 + tcl::dict::set TK_colour_map DarkSlateBlue 72-61-139 + tcl::dict::set TK_colour_map DarkSlateGray 47-79-79 + tcl::dict::set TK_colour_map DarkSlateGray1 151-255-255 + tcl::dict::set TK_colour_map DarkSlateGray2 141-238-238 + tcl::dict::set TK_colour_map DarkSlateGray3 121-205-205 + tcl::dict::set TK_colour_map DarkSlateGray4 82-139-139 + tcl::dict::set TK_colour_map DarkSlateGrey 47-79-79 + tcl::dict::set TK_colour_map DarkTurquoise 0-206-209 + tcl::dict::set TK_colour_map DarkViolet 148-0-211 + tcl::dict::set TK_colour_map "deep pink" 255-20-147 + tcl::dict::set TK_colour_map "deep sky blue" 0-191-255 + tcl::dict::set TK_colour_map DeepPink 255-20-147 + tcl::dict::set TK_colour_map DeepPink1 255-20-147 + tcl::dict::set TK_colour_map DeepPink2 238-18-137 + tcl::dict::set TK_colour_map DeepPink3 205-16-118 + tcl::dict::set TK_colour_map DeepPink4 139-10-80 + tcl::dict::set TK_colour_map DeepSkyBlue 0-191-255 + tcl::dict::set TK_colour_map DeepSkyBlue1 0-191-255 + tcl::dict::set TK_colour_map DeepSkyBlue2 0-178-238 + tcl::dict::set TK_colour_map DeepSkyBlue3 0-154-205 + tcl::dict::set TK_colour_map DeepSkyBlue4 0-104-139 + tcl::dict::set TK_colour_map "dim gray" 105-105-105 + tcl::dict::set TK_colour_map "dim grey" 105-105-105 + tcl::dict::set TK_colour_map DimGray 105-105-105 + tcl::dict::set TK_colour_map DimGrey 105-105-105 + tcl::dict::set TK_colour_map "dodger blue" 30-144-255 + tcl::dict::set TK_colour_map DodgerBlue 30-144-255 + tcl::dict::set TK_colour_map DodgerBlue1 30-144-255 + tcl::dict::set TK_colour_map DodgerBlue2 28-134-238 + tcl::dict::set TK_colour_map DodgerBlue3 24-116-205 + tcl::dict::set TK_colour_map DodgerBlue4 16-78-139 + tcl::dict::set TK_colour_map firebrick 178-34-34 + tcl::dict::set TK_colour_map firebrick1 255-48-48 + tcl::dict::set TK_colour_map firebrick2 238-44-44 + tcl::dict::set TK_colour_map firebrick3 205-38-38 + tcl::dict::set TK_colour_map firebrick4 139-26-26 + tcl::dict::set TK_colour_map "floral white" 255-250-240 + tcl::dict::set TK_colour_map FloralWhite 255-250-240 + tcl::dict::set TK_colour_map "forest green" 34-139-34 + tcl::dict::set TK_colour_map ForestGreen 34-139-34 + tcl::dict::set TK_colour_map fuchsia 255-0-255 + tcl::dict::set TK_colour_map gainsboro 220-220-220 + tcl::dict::set TK_colour_map "ghost white" 248-248-255 + tcl::dict::set TK_colour_map GhostWhite 248-248-255 + tcl::dict::set TK_colour_map gold 255-215-0 + tcl::dict::set TK_colour_map gold1 255-215-0 + tcl::dict::set TK_colour_map gold2 238-201-0 + tcl::dict::set TK_colour_map gold3 205-173-0 + tcl::dict::set TK_colour_map gold4 139-117-0 + tcl::dict::set TK_colour_map goldenrod 218-165-32 + tcl::dict::set TK_colour_map goldenrod1 255-193-37 + tcl::dict::set TK_colour_map goldenrod2 238-180-34 + tcl::dict::set TK_colour_map goldenrod3 205-155-29 + tcl::dict::set TK_colour_map goldenrod4 139-105-20 + tcl::dict::set TK_colour_map gray 128-128-128 + tcl::dict::set TK_colour_map gray0 0-0-0 + tcl::dict::set TK_colour_map gray1 3-3-3 + tcl::dict::set TK_colour_map gray2 5-5-5 + tcl::dict::set TK_colour_map gray3 8-8-8 + tcl::dict::set TK_colour_map gray4 10-10-10 + tcl::dict::set TK_colour_map gray5 13-13-13 + tcl::dict::set TK_colour_map gray6 15-15-15 + tcl::dict::set TK_colour_map gray7 18-18-18 + tcl::dict::set TK_colour_map gray8 20-20-20 + tcl::dict::set TK_colour_map gray9 23-23-23 + tcl::dict::set TK_colour_map gray10 26-26-26 + tcl::dict::set TK_colour_map gray11 28-28-28 + tcl::dict::set TK_colour_map gray12 31-31-31 + tcl::dict::set TK_colour_map gray13 33-33-33 + tcl::dict::set TK_colour_map gray14 36-36-36 + tcl::dict::set TK_colour_map gray15 38-38-38 + tcl::dict::set TK_colour_map gray16 41-41-41 + tcl::dict::set TK_colour_map gray17 43-43-43 + tcl::dict::set TK_colour_map gray18 46-46-46 + tcl::dict::set TK_colour_map gray19 48-48-48 + tcl::dict::set TK_colour_map gray20 51-51-51 + tcl::dict::set TK_colour_map gray21 54-54-54 + tcl::dict::set TK_colour_map gray22 56-56-56 + tcl::dict::set TK_colour_map gray23 59-59-59 + tcl::dict::set TK_colour_map gray24 61-61-61 + tcl::dict::set TK_colour_map gray25 64-64-64 + tcl::dict::set TK_colour_map gray26 66-66-66 + tcl::dict::set TK_colour_map gray27 69-69-69 + tcl::dict::set TK_colour_map gray28 71-71-71 + tcl::dict::set TK_colour_map gray29 74-74-74 + tcl::dict::set TK_colour_map gray30 77-77-77 + tcl::dict::set TK_colour_map gray31 79-79-79 + tcl::dict::set TK_colour_map gray32 82-82-82 + tcl::dict::set TK_colour_map gray33 84-84-84 + tcl::dict::set TK_colour_map gray34 87-87-87 + tcl::dict::set TK_colour_map gray35 89-89-89 + tcl::dict::set TK_colour_map gray36 92-92-92 + tcl::dict::set TK_colour_map gray37 94-94-94 + tcl::dict::set TK_colour_map gray38 97-97-97 + tcl::dict::set TK_colour_map gray39 99-99-99 + tcl::dict::set TK_colour_map gray40 102-102-102 + tcl::dict::set TK_colour_map gray41 105-105-105 + tcl::dict::set TK_colour_map gray42 107-107-107 + tcl::dict::set TK_colour_map gray43 110-110-110 + tcl::dict::set TK_colour_map gray44 112-112-112 + tcl::dict::set TK_colour_map gray45 115-115-115 + tcl::dict::set TK_colour_map gray46 117-117-117 + tcl::dict::set TK_colour_map gray47 120-120-120 + tcl::dict::set TK_colour_map gray48 122-122-122 + tcl::dict::set TK_colour_map gray49 125-125-125 + tcl::dict::set TK_colour_map gray50 127-127-127 + tcl::dict::set TK_colour_map gray51 130-130-130 + tcl::dict::set TK_colour_map gray52 133-133-133 + tcl::dict::set TK_colour_map gray53 135-135-135 + tcl::dict::set TK_colour_map gray54 138-138-138 + tcl::dict::set TK_colour_map gray55 140-140-140 + tcl::dict::set TK_colour_map gray56 143-143-143 + tcl::dict::set TK_colour_map gray57 145-145-145 + tcl::dict::set TK_colour_map gray58 148-148-148 + tcl::dict::set TK_colour_map gray59 150-150-150 + tcl::dict::set TK_colour_map gray60 153-153-153 + tcl::dict::set TK_colour_map gray61 156-156-156 + tcl::dict::set TK_colour_map gray62 158-158-158 + tcl::dict::set TK_colour_map gray63 161-161-161 + tcl::dict::set TK_colour_map gray64 163-163-163 + tcl::dict::set TK_colour_map gray65 166-166-166 + tcl::dict::set TK_colour_map gray66 168-168-168 + tcl::dict::set TK_colour_map gray67 171-171-171 + tcl::dict::set TK_colour_map gray68 173-173-173 + tcl::dict::set TK_colour_map gray69 176-176-176 + tcl::dict::set TK_colour_map gray70 179-179-179 + tcl::dict::set TK_colour_map gray71 181-181-181 + tcl::dict::set TK_colour_map gray72 184-184-184 + tcl::dict::set TK_colour_map gray73 186-186-186 + tcl::dict::set TK_colour_map gray74 189-189-189 + tcl::dict::set TK_colour_map gray75 191-191-191 + tcl::dict::set TK_colour_map gray76 194-194-194 + tcl::dict::set TK_colour_map gray77 196-196-196 + tcl::dict::set TK_colour_map gray78 199-199-199 + tcl::dict::set TK_colour_map gray79 201-201-201 + tcl::dict::set TK_colour_map gray80 204-204-204 + tcl::dict::set TK_colour_map gray81 207-207-207 + tcl::dict::set TK_colour_map gray82 209-209-209 + tcl::dict::set TK_colour_map gray83 212-212-212 + tcl::dict::set TK_colour_map gray84 214-214-214 + tcl::dict::set TK_colour_map gray85 217-217-217 + tcl::dict::set TK_colour_map gray86 219-219-219 + tcl::dict::set TK_colour_map gray87 222-222-222 + tcl::dict::set TK_colour_map gray88 224-224-224 + tcl::dict::set TK_colour_map gray89 227-227-227 + tcl::dict::set TK_colour_map gray90 229-229-229 + tcl::dict::set TK_colour_map gray91 232-232-232 + tcl::dict::set TK_colour_map gray92 235-235-235 + tcl::dict::set TK_colour_map gray93 237-237-237 + tcl::dict::set TK_colour_map gray94 240-240-240 + tcl::dict::set TK_colour_map gray95 242-242-242 + tcl::dict::set TK_colour_map gray96 245-245-245 + tcl::dict::set TK_colour_map gray97 247-247-247 + tcl::dict::set TK_colour_map gray98 250-250-250 + tcl::dict::set TK_colour_map gray99 252-252-252 + tcl::dict::set TK_colour_map gray100 255-255-255 + tcl::dict::set TK_colour_map green 0-128-0 + tcl::dict::set TK_colour_map "green yellow" 173-255-47 + tcl::dict::set TK_colour_map green1 0-255-0 + tcl::dict::set TK_colour_map green2 0-238-0 + tcl::dict::set TK_colour_map green3 0-205-0 + tcl::dict::set TK_colour_map green4 0-139-0 + tcl::dict::set TK_colour_map GreenYellow 173-255-47 + tcl::dict::set TK_colour_map grey 128-128-128 + tcl::dict::set TK_colour_map grey0 0-0-0 + tcl::dict::set TK_colour_map grey1 3-3-3 + tcl::dict::set TK_colour_map grey2 5-5-5 + tcl::dict::set TK_colour_map grey3 8-8-8 + tcl::dict::set TK_colour_map grey4 10-10-10 + tcl::dict::set TK_colour_map grey5 13-13-13 + tcl::dict::set TK_colour_map grey6 15-15-15 + tcl::dict::set TK_colour_map grey7 18-18-18 + tcl::dict::set TK_colour_map grey8 20-20-20 + tcl::dict::set TK_colour_map grey9 23-23-23 + tcl::dict::set TK_colour_map grey10 26-26-26 + tcl::dict::set TK_colour_map grey11 28-28-28 + tcl::dict::set TK_colour_map grey12 31-31-31 + tcl::dict::set TK_colour_map grey13 33-33-33 + tcl::dict::set TK_colour_map grey14 36-36-36 + tcl::dict::set TK_colour_map grey15 38-38-38 + tcl::dict::set TK_colour_map grey16 41-41-41 + tcl::dict::set TK_colour_map grey17 43-43-43 + tcl::dict::set TK_colour_map grey18 46-46-46 + tcl::dict::set TK_colour_map grey19 48-48-48 + tcl::dict::set TK_colour_map grey20 51-51-51 + tcl::dict::set TK_colour_map grey21 54-54-54 + tcl::dict::set TK_colour_map grey22 56-56-56 + tcl::dict::set TK_colour_map grey23 59-59-59 + tcl::dict::set TK_colour_map grey24 61-61-61 + tcl::dict::set TK_colour_map grey25 64-64-64 + tcl::dict::set TK_colour_map grey26 66-66-66 + tcl::dict::set TK_colour_map grey27 69-69-69 + tcl::dict::set TK_colour_map grey28 71-71-71 + tcl::dict::set TK_colour_map grey29 74-74-74 + tcl::dict::set TK_colour_map grey30 77-77-77 + tcl::dict::set TK_colour_map grey31 79-79-79 + tcl::dict::set TK_colour_map grey32 82-82-82 + tcl::dict::set TK_colour_map grey33 84-84-84 + tcl::dict::set TK_colour_map grey34 87-87-87 + tcl::dict::set TK_colour_map grey35 89-89-89 + tcl::dict::set TK_colour_map grey36 92-92-92 + tcl::dict::set TK_colour_map grey37 94-94-94 + tcl::dict::set TK_colour_map grey38 97-97-97 + tcl::dict::set TK_colour_map grey39 99-99-99 + tcl::dict::set TK_colour_map grey40 102-102-102 + tcl::dict::set TK_colour_map grey41 105-105-105 + tcl::dict::set TK_colour_map grey42 107-107-107 + tcl::dict::set TK_colour_map grey43 110-110-110 + tcl::dict::set TK_colour_map grey44 112-112-112 + tcl::dict::set TK_colour_map grey45 115-115-115 + tcl::dict::set TK_colour_map grey46 117-117-117 + tcl::dict::set TK_colour_map grey47 120-120-120 + tcl::dict::set TK_colour_map grey48 122-122-122 + tcl::dict::set TK_colour_map grey49 125-125-125 + tcl::dict::set TK_colour_map grey50 127-127-127 + tcl::dict::set TK_colour_map grey51 130-130-130 + tcl::dict::set TK_colour_map grey52 133-133-133 + tcl::dict::set TK_colour_map grey53 135-135-135 + tcl::dict::set TK_colour_map grey54 138-138-138 + tcl::dict::set TK_colour_map grey55 140-140-140 + tcl::dict::set TK_colour_map grey56 143-143-143 + tcl::dict::set TK_colour_map grey57 145-145-145 + tcl::dict::set TK_colour_map grey58 148-148-148 + tcl::dict::set TK_colour_map grey59 150-150-150 + tcl::dict::set TK_colour_map grey60 153-153-153 + tcl::dict::set TK_colour_map grey61 156-156-156 + tcl::dict::set TK_colour_map grey62 158-158-158 + tcl::dict::set TK_colour_map grey63 161-161-161 + tcl::dict::set TK_colour_map grey64 163-163-163 + tcl::dict::set TK_colour_map grey65 166-166-166 + tcl::dict::set TK_colour_map grey66 168-168-168 + tcl::dict::set TK_colour_map grey67 171-171-171 + tcl::dict::set TK_colour_map grey68 173-173-173 + tcl::dict::set TK_colour_map grey69 176-176-176 + tcl::dict::set TK_colour_map grey70 179-179-179 + tcl::dict::set TK_colour_map grey71 181-181-181 + tcl::dict::set TK_colour_map grey72 184-184-184 + tcl::dict::set TK_colour_map grey73 186-186-186 + tcl::dict::set TK_colour_map grey74 189-189-189 + tcl::dict::set TK_colour_map grey75 191-191-191 + tcl::dict::set TK_colour_map grey76 194-194-194 + tcl::dict::set TK_colour_map grey77 196-196-196 + tcl::dict::set TK_colour_map grey78 199-199-199 + tcl::dict::set TK_colour_map grey79 201-201-201 + tcl::dict::set TK_colour_map grey80 204-204-204 + tcl::dict::set TK_colour_map grey81 207-207-207 + tcl::dict::set TK_colour_map grey82 209-209-209 + tcl::dict::set TK_colour_map grey83 212-212-212 + tcl::dict::set TK_colour_map grey84 214-214-214 + tcl::dict::set TK_colour_map grey85 217-217-217 + tcl::dict::set TK_colour_map grey86 219-219-219 + tcl::dict::set TK_colour_map grey87 222-222-222 + tcl::dict::set TK_colour_map grey88 224-224-224 + tcl::dict::set TK_colour_map grey89 227-227-227 + tcl::dict::set TK_colour_map grey90 229-229-229 + tcl::dict::set TK_colour_map grey91 232-232-232 + tcl::dict::set TK_colour_map grey92 235-235-235 + tcl::dict::set TK_colour_map grey93 237-237-237 + tcl::dict::set TK_colour_map grey94 240-240-240 + tcl::dict::set TK_colour_map grey95 242-242-242 + tcl::dict::set TK_colour_map grey96 245-245-245 + tcl::dict::set TK_colour_map grey97 247-247-247 + tcl::dict::set TK_colour_map grey98 250-250-250 + tcl::dict::set TK_colour_map grey99 252-252-252 + tcl::dict::set TK_colour_map grey100 255-255-255 + tcl::dict::set TK_colour_map honeydew 240-255-240 + tcl::dict::set TK_colour_map honeydew1 240-255-240 + tcl::dict::set TK_colour_map honeydew2 224-238-224 + tcl::dict::set TK_colour_map honeydew3 193-205-193 + tcl::dict::set TK_colour_map honeydew4 131-139-131 + tcl::dict::set TK_colour_map "hot pink" 255-105-180 + tcl::dict::set TK_colour_map HotPink 255-105-180 + tcl::dict::set TK_colour_map HotPink1 255-110-180 + tcl::dict::set TK_colour_map HotPink2 238-106-167 + tcl::dict::set TK_colour_map HotPink3 205-96-144 + tcl::dict::set TK_colour_map HotPink4 139-58-98 + tcl::dict::set TK_colour_map "indian red" 205-92-92 + tcl::dict::set TK_colour_map IndianRed 205-92-92 + tcl::dict::set TK_colour_map IndianRed1 255-106-106 + tcl::dict::set TK_colour_map IndianRed2 238-99-99 + tcl::dict::set TK_colour_map IndianRed3 205-85-85 + tcl::dict::set TK_colour_map IndianRed4 139-58-58 + tcl::dict::set TK_colour_map indigo 75-0-130 + tcl::dict::set TK_colour_map ivory 255-255-240 + tcl::dict::set TK_colour_map ivory1 255-255-240 + tcl::dict::set TK_colour_map ivory2 238-238-224 + tcl::dict::set TK_colour_map ivory3 205-205-193 + tcl::dict::set TK_colour_map ivory4 139-139-131 + tcl::dict::set TK_colour_map khaki 240-230-140 + tcl::dict::set TK_colour_map khaki1 255-246-143 + tcl::dict::set TK_colour_map khaki2 238-230-133 + tcl::dict::set TK_colour_map khaki3 205-198-115 + tcl::dict::set TK_colour_map khaki4 139-134-78 + tcl::dict::set TK_colour_map lavender 230-230-250 + tcl::dict::set TK_colour_map "lavender blush" 255-240-245 + tcl::dict::set TK_colour_map LavenderBlush 255-240-245 + tcl::dict::set TK_colour_map LavenderBlush1 255-240-245 + tcl::dict::set TK_colour_map LavenderBlush2 238-224-229 + tcl::dict::set TK_colour_map LavenderBlush3 205-193-197 + tcl::dict::set TK_colour_map LavenderBlush4 139-131-134 + tcl::dict::set TK_colour_map "lawn green" 124-252-0 + tcl::dict::set TK_colour_map LawnGreen 124-252-0 + tcl::dict::set TK_colour_map "lemon chiffon" 255-250-205 + tcl::dict::set TK_colour_map LemonChiffon 255-250-205 + tcl::dict::set TK_colour_map LemonChiffon1 255-250-205 + tcl::dict::set TK_colour_map LemonChiffon2 238-233-191 + tcl::dict::set TK_colour_map LemonChiffon3 205-201-165 + tcl::dict::set TK_colour_map LemonChiffon4 139-137-112 + tcl::dict::set TK_colour_map "light blue" 173-216-230 + tcl::dict::set TK_colour_map "light coral" 240-128-128 + tcl::dict::set TK_colour_map "light cyan" 224-255-255 + tcl::dict::set TK_colour_map "light goldenrod" 238-221-130 + tcl::dict::set TK_colour_map "light goldenrod yellow" 250-250-210 + tcl::dict::set TK_colour_map "light gray" 211-211-211 + tcl::dict::set TK_colour_map "light green" 144-238-144 + tcl::dict::set TK_colour_map "light grey" 211-211-211 + tcl::dict::set TK_colour_map "light pink" 255-182-193 + tcl::dict::set TK_colour_map "light salmon" 255-160-122 + tcl::dict::set TK_colour_map "light sea green" 32-178-170 + tcl::dict::set TK_colour_map "light sky blue" 135-206-250 + tcl::dict::set TK_colour_map "light slate blue" 132-112-255 + tcl::dict::set TK_colour_map "light slate gray" 119-136-153 + tcl::dict::set TK_colour_map "light slate grey" 119-136-153 + tcl::dict::set TK_colour_map "light steel blue" 176-196-222 + tcl::dict::set TK_colour_map "light yellow" 255-255-224 + tcl::dict::set TK_colour_map LightBlue 173-216-230 + tcl::dict::set TK_colour_map LightBlue1 191-239-255 + tcl::dict::set TK_colour_map LightBlue2 178-223-238 + tcl::dict::set TK_colour_map LightBlue3 154-192-205 + tcl::dict::set TK_colour_map LightBlue4 104-131-139 + tcl::dict::set TK_colour_map LightCoral 240-128-128 + tcl::dict::set TK_colour_map LightCyan 224-255-255 + tcl::dict::set TK_colour_map LightCyan1 224-255-255 + tcl::dict::set TK_colour_map LightCyan2 209-238-238 + tcl::dict::set TK_colour_map LightCyan3 180-205-205 + tcl::dict::set TK_colour_map LightCyan4 122-139-139 + tcl::dict::set TK_colour_map LightGoldenrod 238-221-130 + tcl::dict::set TK_colour_map LightGoldenrod1 255-236-139 + tcl::dict::set TK_colour_map LightGoldenrod2 238-220-130 + tcl::dict::set TK_colour_map LightGoldenrod3 205-190-112 + tcl::dict::set TK_colour_map LightGoldenrod4 139-129-76 + tcl::dict::set TK_colour_map LightGoldenrodYellow 250-250-210 + tcl::dict::set TK_colour_map LightGray 211-211-211 + tcl::dict::set TK_colour_map LightGreen 144-238-144 + tcl::dict::set TK_colour_map LightGrey 211-211-211 + tcl::dict::set TK_colour_map LightPink 255-182-193 + tcl::dict::set TK_colour_map LightPink1 255-174-185 + tcl::dict::set TK_colour_map LightPink2 238-162-173 + tcl::dict::set TK_colour_map LightPink3 205-140-149 + tcl::dict::set TK_colour_map LightPink4 139-95-101 + tcl::dict::set TK_colour_map LightSalmon 255-160-122 + tcl::dict::set TK_colour_map LightSalmon1 255-160-122 + tcl::dict::set TK_colour_map LightSalmon2 238-149-114 + tcl::dict::set TK_colour_map LightSalmon3 205-129-98 + tcl::dict::set TK_colour_map LightSalmon4 139-87-66 + tcl::dict::set TK_colour_map LightSeaGreen 32-178-170 + tcl::dict::set TK_colour_map LightSkyBlue 135-206-250 + tcl::dict::set TK_colour_map LightSkyBlue1 176-226-255 + tcl::dict::set TK_colour_map LightSkyBlue2 164-211-238 + tcl::dict::set TK_colour_map LightSkyBlue3 141-182-205 + tcl::dict::set TK_colour_map LightSkyBlue4 96-123-139 + tcl::dict::set TK_colour_map LightSlateBlue 132-112-255 + tcl::dict::set TK_colour_map LightSlateGray 119-136-153 + tcl::dict::set TK_colour_map LightSlateGrey 119-136-153 + tcl::dict::set TK_colour_map LightSteelBlue 176-196-222 + tcl::dict::set TK_colour_map LightSteelBlue1 202-225-255 + tcl::dict::set TK_colour_map LightSteelBlue2 188-210-238 + tcl::dict::set TK_colour_map LightSteelBlue3 162-181-205 + tcl::dict::set TK_colour_map LightSteelBlue4 110-123-139 + tcl::dict::set TK_colour_map LightYellow 255-255-224 + tcl::dict::set TK_colour_map LightYellow1 255-255-224 + tcl::dict::set TK_colour_map LightYellow2 238-238-209 + tcl::dict::set TK_colour_map LightYellow3 205-205-180 + tcl::dict::set TK_colour_map LightYellow4 139-139-122 + tcl::dict::set TK_colour_map lime 0-255-0 + tcl::dict::set TK_colour_map "lime green" 50-205-50 + tcl::dict::set TK_colour_map LimeGreen 50-205-50 + tcl::dict::set TK_colour_map linen 250-240-230 + tcl::dict::set TK_colour_map magenta 255-0-255 + tcl::dict::set TK_colour_map magenta1 255-0-255 + tcl::dict::set TK_colour_map magenta2 238-0-238 + tcl::dict::set TK_colour_map magenta3 205-0-205 + tcl::dict::set TK_colour_map magenta4 139-0-139 + tcl::dict::set TK_colour_map maroon 128-0-0 + tcl::dict::set TK_colour_map maroon1 255-52-179 + tcl::dict::set TK_colour_map maroon2 238-48-167 + tcl::dict::set TK_colour_map maroon3 205-41-144 + tcl::dict::set TK_colour_map maroon4 139-28-98 + tcl::dict::set TK_colour_map "medium aquamarine" 102-205-170 + tcl::dict::set TK_colour_map "medium blue" 0-0-205 + tcl::dict::set TK_colour_map "medium orchid" 186-85-211 + tcl::dict::set TK_colour_map "medium purple" 147-112-219 + tcl::dict::set TK_colour_map "medium sea green" 60-179-113 + tcl::dict::set TK_colour_map "medium slate blue" 123-104-238 + tcl::dict::set TK_colour_map "medium spring green" 0-250-154 + tcl::dict::set TK_colour_map "medium turquoise" 72-209-204 + tcl::dict::set TK_colour_map "medium violet red" 199-21-133 + tcl::dict::set TK_colour_map MediumAquamarine 102-205-170 + tcl::dict::set TK_colour_map MediumBlue 0-0-205 + tcl::dict::set TK_colour_map MediumOrchid 186-85-211 + tcl::dict::set TK_colour_map MediumOrchid1 224-102-255 + tcl::dict::set TK_colour_map MediumOrchid2 209-95-238 + tcl::dict::set TK_colour_map MediumOrchid3 180-82-205 + tcl::dict::set TK_colour_map MediumOrchid4 122-55-139 + tcl::dict::set TK_colour_map MediumPurple 147-112-219 + tcl::dict::set TK_colour_map MediumPurple1 171-130-255 + tcl::dict::set TK_colour_map MediumPurple2 159-121-238 + tcl::dict::set TK_colour_map MediumPurple3 137-104-205 + tcl::dict::set TK_colour_map MediumPurple4 93-71-139 + tcl::dict::set TK_colour_map MediumSeaGreen 60-179-113 + tcl::dict::set TK_colour_map MediumSlateBlue 123-104-238 + tcl::dict::set TK_colour_map MediumSpringGreen 0-250-154 + tcl::dict::set TK_colour_map MediumTurquoise 72-209-204 + tcl::dict::set TK_colour_map MediumVioletRed 199-21-133 + tcl::dict::set TK_colour_map "midnight blue" 25-25-112 + tcl::dict::set TK_colour_map MidnightBlue 25-25-112 + tcl::dict::set TK_colour_map "mint cream" 245-255-250 + tcl::dict::set TK_colour_map MintCream 245-255-250 + tcl::dict::set TK_colour_map "misty rose" 255-228-225 + tcl::dict::set TK_colour_map MistyRose 255-228-225 + tcl::dict::set TK_colour_map MistyRose1 255-228-225 + tcl::dict::set TK_colour_map MistyRose2 238-213-210 + tcl::dict::set TK_colour_map MistyRose3 205-183-181 + tcl::dict::set TK_colour_map MistyRose4 139-125-123 + tcl::dict::set TK_colour_map moccasin 255-228-181 + tcl::dict::set TK_colour_map "navajo white" 255-222-173 + tcl::dict::set TK_colour_map NavajoWhite 255-222-173 + tcl::dict::set TK_colour_map NavajoWhite1 255-222-173 + tcl::dict::set TK_colour_map NavajoWhite2 238-207-161 + tcl::dict::set TK_colour_map NavajoWhite3 205-179-139 + tcl::dict::set TK_colour_map NavajoWhite4 139-121-94 + tcl::dict::set TK_colour_map navy 0-0-128 + tcl::dict::set TK_colour_map "navy blue" 0-0-128 + tcl::dict::set TK_colour_map NavyBlue 0-0-128 + tcl::dict::set TK_colour_map "old lace" 253-245-230 + tcl::dict::set TK_colour_map OldLace 253-245-230 + tcl::dict::set TK_colour_map olive 128-128-0 + tcl::dict::set TK_colour_map "olive drab" 107-142-35 + tcl::dict::set TK_colour_map OliveDrab 107-142-35 + tcl::dict::set TK_colour_map OliveDrab1 192-255-62 + tcl::dict::set TK_colour_map OliveDrab2 179-238-58 + tcl::dict::set TK_colour_map OliveDrab3 154-205-50 + tcl::dict::set TK_colour_map OliveDrab4 105-139-34 + tcl::dict::set TK_colour_map orange 255-165-0 + tcl::dict::set TK_colour_map "orange red" 255-69-0 + tcl::dict::set TK_colour_map orange1 255-165-0 + tcl::dict::set TK_colour_map orange2 238-154-0 + tcl::dict::set TK_colour_map orange3 205-133-0 + tcl::dict::set TK_colour_map orange4 139-90-0 + tcl::dict::set TK_colour_map OrangeRed 255-69-0 + tcl::dict::set TK_colour_map OrangeRed1 255-69-0 + tcl::dict::set TK_colour_map OrangeRed2 238-64-0 + tcl::dict::set TK_colour_map OrangeRed3 205-55-0 + tcl::dict::set TK_colour_map OrangeRed4 139-37-0 + tcl::dict::set TK_colour_map orchid 218-112-214 + tcl::dict::set TK_colour_map orchid1 255-131-250 + tcl::dict::set TK_colour_map orchid2 238-122-233 + tcl::dict::set TK_colour_map orchid3 205-105-201 + tcl::dict::set TK_colour_map orchid4 139-71-137 + tcl::dict::set TK_colour_map "pale goldenrod" 238-232-170 + tcl::dict::set TK_colour_map "pale green" 152-251-152 + tcl::dict::set TK_colour_map "pale turquoise" 175-238-238 + tcl::dict::set TK_colour_map "pale violet red" 219-112-147 + tcl::dict::set TK_colour_map PaleGoldenrod 238-232-170 + tcl::dict::set TK_colour_map PaleGreen 152-251-152 + tcl::dict::set TK_colour_map PaleGreen1 154-255-154 + tcl::dict::set TK_colour_map PaleGreen2 144-238-144 + tcl::dict::set TK_colour_map PaleGreen3 124-205-124 + tcl::dict::set TK_colour_map PaleGreen4 84-139-84 + tcl::dict::set TK_colour_map PaleTurquoise 175-238-238 + tcl::dict::set TK_colour_map PaleTurquoise1 187-255-255 + tcl::dict::set TK_colour_map PaleTurquoise2 174-238-238 + tcl::dict::set TK_colour_map PaleTurquoise3 150-205-205 + tcl::dict::set TK_colour_map PaleTurquoise4 102-139-139 + tcl::dict::set TK_colour_map PaleVioletRed 219-112-147 + tcl::dict::set TK_colour_map PaleVioletRed1 255-130-171 + tcl::dict::set TK_colour_map PaleVioletRed2 238-121-159 + tcl::dict::set TK_colour_map PaleVioletRed3 205-104-127 + tcl::dict::set TK_colour_map PaleVioletRed4 139-71-93 + tcl::dict::set TK_colour_map "papaya whip" 255-239-213 + tcl::dict::set TK_colour_map PapayaWhip 255-239-213 + tcl::dict::set TK_colour_map "peach puff" 255-218-185 + tcl::dict::set TK_colour_map PeachPuff 255-218-185 + tcl::dict::set TK_colour_map PeachPuff1 255-218-185 + tcl::dict::set TK_colour_map PeachPuff2 238-203-173 + tcl::dict::set TK_colour_map PeachPuff3 205-175-149 + tcl::dict::set TK_colour_map PeachPuff4 139-119-101 + tcl::dict::set TK_colour_map peru 205-133-63 + tcl::dict::set TK_colour_map pink 255-192-203 + tcl::dict::set TK_colour_map pink1 255-181-197 + tcl::dict::set TK_colour_map pink2 238-169-184 + tcl::dict::set TK_colour_map pink3 205-145-158 + tcl::dict::set TK_colour_map pink4 139-99-108 + tcl::dict::set TK_colour_map plum 221-160-221 + tcl::dict::set TK_colour_map plum1 255-187-255 + tcl::dict::set TK_colour_map plum2 238-174-238 + tcl::dict::set TK_colour_map plum3 205-150-205 + tcl::dict::set TK_colour_map plum4 139-102-139 + tcl::dict::set TK_colour_map "powder blue" 176-224-230 + tcl::dict::set TK_colour_map PowderBlue 176-224-230 + tcl::dict::set TK_colour_map purple 128-0-128 + tcl::dict::set TK_colour_map purple1 155-48-255 + tcl::dict::set TK_colour_map purple2 145-44-238 + tcl::dict::set TK_colour_map purple3 125-38-205 + tcl::dict::set TK_colour_map purple4 85-26-139 + tcl::dict::set TK_colour_map red 255-0-0 + tcl::dict::set TK_colour_map red1 255-0-0 + tcl::dict::set TK_colour_map red2 238-0-0 + tcl::dict::set TK_colour_map red3 205-0-0 + tcl::dict::set TK_colour_map red4 139-0-0 + tcl::dict::set TK_colour_map "rosy brown" 188-143-143 + tcl::dict::set TK_colour_map RosyBrown 188-143-143 + tcl::dict::set TK_colour_map RosyBrown1 255-193-193 + tcl::dict::set TK_colour_map RosyBrown2 238-180-180 + tcl::dict::set TK_colour_map RosyBrown3 205-155-155 + tcl::dict::set TK_colour_map RosyBrown4 139-105-105 + tcl::dict::set TK_colour_map "royal blue" 65-105-225 + tcl::dict::set TK_colour_map RoyalBlue 65-105-225 + tcl::dict::set TK_colour_map RoyalBlue1 72-118-255 + tcl::dict::set TK_colour_map RoyalBlue2 67-110-238 + tcl::dict::set TK_colour_map RoyalBlue3 58-95-205 + tcl::dict::set TK_colour_map RoyalBlue4 39-64-139 + tcl::dict::set TK_colour_map "saddle brown" 139-69-19 + tcl::dict::set TK_colour_map SaddleBrown 139-69-19 + tcl::dict::set TK_colour_map salmon 250-128-114 + tcl::dict::set TK_colour_map salmon1 255-140-105 + tcl::dict::set TK_colour_map salmon2 238-130-98 + tcl::dict::set TK_colour_map salmon3 205-112-84 + tcl::dict::set TK_colour_map salmon4 139-76-57 + tcl::dict::set TK_colour_map "sandy brown" 244-164-96 + tcl::dict::set TK_colour_map SandyBrown 244-164-96 + tcl::dict::set TK_colour_map "sea green" 46-139-87 + tcl::dict::set TK_colour_map SeaGreen 46-139-87 + tcl::dict::set TK_colour_map SeaGreen1 84-255-159 + tcl::dict::set TK_colour_map SeaGreen2 78-238-148 + tcl::dict::set TK_colour_map SeaGreen3 67-205-128 + tcl::dict::set TK_colour_map SeaGreen4 46-139-87 + tcl::dict::set TK_colour_map seashell 255-245-238 + tcl::dict::set TK_colour_map seashell1 255-245-238 + tcl::dict::set TK_colour_map seashell2 238-229-222 + tcl::dict::set TK_colour_map seashell3 205-197-191 + tcl::dict::set TK_colour_map seashell4 139-134-130 + tcl::dict::set TK_colour_map sienna 160-82-45 + tcl::dict::set TK_colour_map sienna1 255-130-71 + tcl::dict::set TK_colour_map sienna2 238-121-66 + tcl::dict::set TK_colour_map sienna3 205-104-57 + tcl::dict::set TK_colour_map sienna4 139-71-38 + tcl::dict::set TK_colour_map silver 192-192-192 + tcl::dict::set TK_colour_map "sky blue" 135-206-235 + tcl::dict::set TK_colour_map SkyBlue 135-206-235 + tcl::dict::set TK_colour_map SkyBlue1 135-206-255 + tcl::dict::set TK_colour_map SkyBlue2 126-192-238 + tcl::dict::set TK_colour_map SkyBlue3 108-166-205 + tcl::dict::set TK_colour_map SkyBlue4 74-112-139 + tcl::dict::set TK_colour_map "slate blue" 106-90-205 + tcl::dict::set TK_colour_map "slate gray" 112-128-144 + tcl::dict::set TK_colour_map "slate grey" 112-128-144 + tcl::dict::set TK_colour_map SlateBlue 106-90-205 + tcl::dict::set TK_colour_map SlateBlue1 131-111-255 + tcl::dict::set TK_colour_map SlateBlue2 122-103-238 + tcl::dict::set TK_colour_map SlateBlue3 105-89-205 + tcl::dict::set TK_colour_map SlateBlue4 71-60-139 + tcl::dict::set TK_colour_map SlateGray 112-128-144 + tcl::dict::set TK_colour_map SlateGray1 198-226-255 + tcl::dict::set TK_colour_map SlateGray2 185-211-238 + tcl::dict::set TK_colour_map SlateGray3 159-182-205 + tcl::dict::set TK_colour_map SlateGray4 108-123-139 + tcl::dict::set TK_colour_map SlateGrey 112-128-144 + tcl::dict::set TK_colour_map snow 255-250-250 + tcl::dict::set TK_colour_map snow1 255-250-250 + tcl::dict::set TK_colour_map snow2 238-233-233 + tcl::dict::set TK_colour_map snow3 205-201-201 + tcl::dict::set TK_colour_map snow4 139-137-137 + tcl::dict::set TK_colour_map "spring green" 0-255-127 + tcl::dict::set TK_colour_map SpringGreen 0-255-127 + tcl::dict::set TK_colour_map SpringGreen1 0-255-127 + tcl::dict::set TK_colour_map SpringGreen2 0-238-118 + tcl::dict::set TK_colour_map SpringGreen3 0-205-102 + tcl::dict::set TK_colour_map SpringGreen4 0-139-69 + tcl::dict::set TK_colour_map "steel blue" 70-130-180 + tcl::dict::set TK_colour_map SteelBlue 70-130-180 + tcl::dict::set TK_colour_map SteelBlue1 99-184-255 + tcl::dict::set TK_colour_map SteelBlue2 92-172-238 + tcl::dict::set TK_colour_map SteelBlue3 79-148-205 + tcl::dict::set TK_colour_map SteelBlue4 54-100-139 + tcl::dict::set TK_colour_map tan 210-180-140 + tcl::dict::set TK_colour_map tan1 255-165-79 + tcl::dict::set TK_colour_map tan2 238-154-73 + tcl::dict::set TK_colour_map tan3 205-133-63 + tcl::dict::set TK_colour_map tan4 139-90-43 + tcl::dict::set TK_colour_map teal 0-128-128 + tcl::dict::set TK_colour_map thistle 216-191-216 + tcl::dict::set TK_colour_map thistle1 255-225-255 + tcl::dict::set TK_colour_map thistle2 238-210-238 + tcl::dict::set TK_colour_map thistle3 205-181-205 + tcl::dict::set TK_colour_map thistle4 139-123-139 + tcl::dict::set TK_colour_map tomato 255-99-71 + tcl::dict::set TK_colour_map tomato1 255-99-71 + tcl::dict::set TK_colour_map tomato2 238-92-66 + tcl::dict::set TK_colour_map tomato3 205-79-57 + tcl::dict::set TK_colour_map tomato4 139-54-38 + tcl::dict::set TK_colour_map turquoise 64-224-208 + tcl::dict::set TK_colour_map turquoise1 0-245-255 + tcl::dict::set TK_colour_map turquoise2 0-229-238 + tcl::dict::set TK_colour_map turquoise3 0-197-205 + tcl::dict::set TK_colour_map turquoise4 0-134-139 + tcl::dict::set TK_colour_map violet 238-130-238 + tcl::dict::set TK_colour_map "violet red" 208-32-144 + tcl::dict::set TK_colour_map VioletRed 208-32-144 + tcl::dict::set TK_colour_map VioletRed1 255-62-150 + tcl::dict::set TK_colour_map VioletRed2 238-58-140 + tcl::dict::set TK_colour_map VioletRed3 205-50-120 + tcl::dict::set TK_colour_map VioletRed4 139-34-82 + tcl::dict::set TK_colour_map wheat 245-222-179 + tcl::dict::set TK_colour_map wheat1 255-231-186 + tcl::dict::set TK_colour_map wheat2 238-216-174 + tcl::dict::set TK_colour_map wheat3 205-186-150 + tcl::dict::set TK_colour_map wheat4 139-126-102 + tcl::dict::set TK_colour_map white 255-255-255 + tcl::dict::set TK_colour_map "white smoke" 245-245-245 + tcl::dict::set TK_colour_map WhiteSmoke 245-245-245 + tcl::dict::set TK_colour_map yellow 255-255-0 + tcl::dict::set TK_colour_map "yellow green" 154-205-50 + tcl::dict::set TK_colour_map yellow1 255-255-0 + tcl::dict::set TK_colour_map yellow2 238-238-0 + tcl::dict::set TK_colour_map yellow3 205-205-0 + tcl::dict::set TK_colour_map yellow4 139-139-0 + tcl::dict::set TK_colour_map YellowGreen 154-205-50 + + variable TK_colour_map_lookup ;#same dict but with lower-case versions added + set TK_colour_map_lookup $TK_colour_map + dict for {key val} $TK_colour_map { + dict set TK_colour_map_lookup [tcl::string::tolower $key] $val ;#no need to test if already present - just set. + } + + variable TK_colour_map_reverse [dict create] + dict for {key val} $TK_colour_map { + dict lappend TK_colour_map_reverse $val $key + } + + #using same order as inital colour map + variable TK_colour_map_merge [dict create] + set seen_names [dict create] + dict for {key val} $TK_colour_map { + if {[dict exists $seen_names $key]} { + continue + } + set allnames [dict get $TK_colour_map_reverse $val] + set names [list] + foreach n $allnames { + if {$n ne $key} { + lappend names $n + } + } + dict set TK_colour_map_merge $key [dict create colour $val names $names] + foreach n $names { + dict set seen_names $n 1 + } + } + unset seen_names + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace ::punk::ansi::colourmap ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval ::punk::ansi::colourmap::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace ::punk::ansi::colourmap::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace ::punk::ansi::colourmap::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::ansi::colourmap +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::ansi::colourmap [tcl::namespace::eval ::punk::ansi::colourmap { + variable pkg ::punk::ansi::colourmap + variable version + set version 999999.0a1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/punk/ansi/colourmap-buildversion.txt b/src/modules/punk/ansi/colourmap-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/punk/ansi/colourmap-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 432712aa..9c8343bd 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -268,6 +268,7 @@ tcl::namespace::eval punk::args::register { #[list_end] [comment {--- end definitions namespace punk::args::register ---}] } +tcl::namespace::eval ::punk::args {} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace @@ -408,6 +409,8 @@ tcl::namespace::eval punk::args { -body (override autogenerated arg info for form) %B%@doc%N% ?opt val...? directive-options: -name -url + %B%@examples%N% ?opt val...? + directive-options: -help %B%@seealso%N% ?opt val...? directive-options: -name -url (for footer - unimplemented) @@ -438,9 +441,35 @@ tcl::namespace::eval punk::args { and trailing values also take spec-options: -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. + A typenamelist represents a multi-value clause where each + value must match the specified type in order. This is not + valid for flags - which can only take a single value. + + typename and entries in typenamelist can take 2 forms: + 1) basic form: elements of llength 1 such as a simple type, + or a pipe-delimited set of type-alternates. + e.g for a single typename: + -type int, -type int|char, -type int|literal(abc) + e.g for a typenamelist + -type {int double}, -type {int|char double} + 2) special form: elements of variable length + e.g for a single typename: + -type {{literal |}} + -type {{literal | | literal (}} + e.g for a typenamelist + -type {{literal |} {stringstartswith abc | int}} + The 2 forms can be mixed: + -type {{literal |} {stringstartswith a|c | int} literal(xyz)|int} + + Defaults to string. If no other restrictions + are required, choosing -type any does the least validation. recognised types: + any + (unvalidated - accepts anything) + none + (used for flags/switches only. Indicates this is + a 'solo' flag ie accepts no value) + Not valid as a member of a clause's typenamelist. int integer number @@ -463,11 +492,9 @@ tcl::namespace::eval punk::args { string (also any of the 'string is' types such as xdigit, graph, punct, lower etc) - any - (unvalidated - accepts anything) - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) + -type string on its own does not need validation, + but still checks for string-related restrictions + such as regexprefail, & minsize literal() (exact match for string) @@ -475,6 +502,9 @@ tcl::namespace::eval punk::args { (prefix match for string, other literal and literalprefix entries specified as alternates using | are used in the calculation) + stringstartswith() + (value must match glob *) + The value of string must not contain pipe char '|' Note that types can be combined with | to indicate an 'or' operation @@ -592,7 +622,8 @@ tcl::namespace::eval punk::args { inner loops in more performance-sensitive code. " @values -min 1 -max -1 - text -type string -multiple 1 -help\ + #text should be a well-formed Tcl list + text -type list -multiple 1 -help\ {Block(s) of text representing the argument definition for a command. At least one must be supplied. If multiple, they are joined together with \n. Using multiple text arguments may be useful to mix curly-braced and double-quoted @@ -1031,6 +1062,7 @@ tcl::namespace::eval punk::args { #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table set seealso_info {} set keywords_info {} + set examples_info {} ###set leader_min 0 ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit #set leader_max "" @@ -1162,6 +1194,8 @@ tcl::namespace::eval punk::args { } } default { + #NOTE - this is switch arm for the literal "default" (@default) - not the default arm of the switch block! + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) @@ -1203,7 +1237,29 @@ tcl::namespace::eval punk::args { # arity system ? #handle multiple parsing styles based on arities and keyword positions (and/or flags?) #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each + + # @form "-synopsis" is optional - and only exists in case the user really wants + # to display something different. The system should generate consistent synopses + # with appropriate italics/bracketing etc. + # For manual -synopsis - features such as italics must be manually added. + + #spitballing.. + #The punk::args parser should generally be able to determine the appropriate form based + #on supplied arguments, e.g automatically using argument counts and matching literals. + #We may need to support some hints for forcing more efficient -form discriminators + # + # e.g compare with -takewhenargsmodulo that is available on @leaders + + #the -arities idea below is a rough one; potentially something to consider.. but + #we want to be able to support command completion.. and things like literals should probably + #take preference for partially typed commands.. as flipping to other forms based on argcount + #could be confusing. Need to match partial command to closest form automatically but allow + #user to lock in a form interactively and see mismatches (?) + #Probably the arity-ranges of a form are best calculated automatically rather than explicitly, + #otherwise we have a strong potential for misdefinition.. (conflict with defined leaders,opts,values) + #The way forward might be to calculate some 'arity' structure from the forms to aid in form-discrimination at arg parse time. + #(this is currently covered in some ways by the LEADER_MIN,LEADER_MAX,OPT_MIN,OPT_MAX,VAL_MIN,VAL_MAX members of the FORMS dict.) + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ # -arities { # 2 @@ -1231,7 +1287,6 @@ tcl::namespace::eval punk::args { # } #todo - #can we generate a form synopsis if -synopsis not supplied? #form id can be list of ints|names?, or * if {[dict exists $at_specs -form]} { @@ -1666,8 +1721,11 @@ tcl::namespace::eval punk::args { #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? set keywords_info [dict merge $keywords_info $at_specs] } + examples { + set examples_info [dict merge $examples_info $at_specs] + } default { - error "punk::args::resolve - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + error "punk::args::resolve - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @examples @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" } } #record_type directive @@ -1859,98 +1917,88 @@ tcl::namespace::eval punk::args { foreach {spec specval} $argdef_values { #literal-key switch - bytecompiled to jumpTable switch -- $spec { - -form { - - } + -form {} -type { #todo - could be a list e.g {any int literal(Test)} #case must be preserved in literal bracketed part set typelist [list] foreach typespec $specval { - set lc_typespec [tcl::string::tolower $typespec] - if {[string match {\?*\?} $lc_typespec]} { - set lc_type [string range $lc_typespec 1 end-1] + if {[string match {\?*\?} $typespec]} { + set tspec [string range $typespec 1 end-1] set optional_clausemember true } else { - set lc_type $lc_typespec + set tspec $typespec set optional_clausemember false } - #normalize here so we don't have to test during actual args parsing in main function - set normtype "" ;#assert - should be overridden in all branches of switch - switch -- $lc_type { - int - integer { - set normtype int - } - double - float { - #review - user may wish to preserve 'float' in help display - consider how best to implement - set normtype double - } - bool - boolean { - set normtype bool - } - char - character { - set normtype char - } - dict - dictionary { - set normtype dict - } - index - indexexpression { - set normtype indexexpression - } - "" - none - solo { - if {$is_opt} { - #review - are we allowing clauses for flags? - #e.g {-flag -type {int int}} - #this isn't very tcl like, where we'd normally mark the flag with -multiple true and - # instead require calling as: -flag -flag - #It seems this is a reasonably rare/unlikely requirement in most commandline tools. - - if {[llength $specval] > 1} { - #makes no sense to have 'none' in a clause - error "punk::args::resolve - invalid -type '$specval' for flag '$argname' ('none' in multitype) @id:$DEF_definition_id" - } - #tcl::dict::set spec_merged -type none - set normtype none - if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { - tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + set type_alternatives [_split_type_expression $tspec] + set normlist [list] + foreach alt $type_alternatives { + set firstword [lindex $alt 0] + set lc_firstword [tcl::string::tolower $firstword] + #normalize here so we don't have to test during actual args parsing in main function + set normtype "" ;#assert - should be overridden in all branches of switch + switch -- $lc_firstword { + int - integer {set normtype int} + double - float { + #review - user may wish to preserve 'float' in help display - consider how best to implement + set normtype double + } + bool - boolean {set normtype bool} + char - character {set normtype char} + dict - dictionary {set normtype dict} + index - indexexpression {set normtype indexexpression} + "" - none - solo { + if {$is_opt} { + #review - are we allowing clauses for flags? + #e.g {-flag -type {int int}} + #this isn't very tcl like, where we'd normally mark the flag with -multiple true and + # instead require calling as: -flag -flag + #It seems this is a reasonably rare/unlikely requirement in most commandline tools. + + if {[llength $specval] > 1} { + #makes no sense to have 'none' in a clause + error "punk::args::resolve - invalid -type '$specval' for flag '$argname' ('none' in multitype) @id:$DEF_definition_id" + } + #tcl::dict::set spec_merged -type none + set normtype none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + } else { + #solo only valid for flags + error "punk::args::resolve - invalid -type 'none|solo' for positional argument '$argname' (only valid for flags/options) @id:$DEF_definition_id" } - } else { - #solo only valid for flags - error "punk::args::resolve - invalid -type 'none|solo' for positional argument '$argname' (only valid for flags/options) @id:$DEF_definition_id" } - } - any - anything { - set normtype any - } - ansi - ansistring { - set normtype ansistring - } - string - globstring { - set normtype $lc_type - } - literal { - if {$is_opt} { - error "punk::args::resolve - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" + any - anything {set normtype any} + ansi - ansistring {set normtype ansistring} + string - globstring {set normtype $lc_firstword} + literal { + #value was split out by _split_type_expression + set normtype literal([lindex $alt 1]) } - #value is the name of the argument - set normtype literal - } - default { - if {[string match literal* $lc_type]} { - #typespec may or may not be of form ?xxx? - set literal_tail [string range [string trim $typespec ?] 7 end] - set normtype literal$literal_tail - } else { + literalprefix { + set normtype literalprefix([lindex $alt 1]) + } + stringstartswith { + set normtype stringstartswith([lindex $alt 1]) + } + stringendswith { + set normtype stringendswith([lindex $alt 1]) + } + default { #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW #tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - set normtype $lc_type + #todo + set normtype $alt } } + lappend normlist $normtype } + set norms [join $normlist |] if {$optional_clausemember} { - lappend typelist ?$normtype? + lappend typelist ?$norms? } else { - lappend typelist $normtype + lappend typelist $norms } } tcl::dict::set spec_merged -type $typelist @@ -2082,7 +2130,7 @@ tcl::namespace::eval punk::args { if {$is_opt} { tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize if {$argname eq "--"} { #force -type none - in case no -type was specified and @opts -type is some other default such as string tcl::dict::set spec_merged -type none @@ -2092,7 +2140,7 @@ tcl::namespace::eval punk::args { } } else { tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize } tcl::dict::set F $fid ARG_INFO $argname $spec_merged #review existence of -default overriding -optional @@ -2229,6 +2277,8 @@ tcl::namespace::eval punk::args { doc_info $doc_info\ package_info $package_info\ seealso_info $seealso_info\ + keywords_info $keywords_info\ + examples_info $examples_info\ id_info $id_info\ FORMS $F\ form_names [dict keys $F]\ @@ -2259,9 +2309,9 @@ tcl::namespace::eval punk::args { namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @examples @formdisplay @seealso @leaders @opts @values leaders opts values} variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @formdisplay @seealso} + directives {@id @package @cmd @ref @doc @examples @formdisplay @seealso} argumenttypes {leaders opts values} remaining_defaults {@leaders @opts @values} } @@ -2468,7 +2518,7 @@ tcl::namespace::eval punk::args { dict set resultdict @id [list -id [dict get $specdict id]] } } - foreach directive {@package @cmd @doc @seealso} { + foreach directive {@package @cmd @doc @examples @seealso} { set dshort [string range $directive 1 end] if {"$directive" in $included_directives} { if {[dict exists $opt_override $directive]} { @@ -2482,6 +2532,7 @@ tcl::namespace::eval punk::args { } #todo @formdisplay + #todo @ref ? #output ordered by leader, option, value @@ -2533,7 +2584,7 @@ tcl::namespace::eval punk::args { } } } - @package - @cmd - @doc - @seealso { + @package - @cmd - @doc - @examples - @seealso { if {"$type" in $included_directives} { set tp [string range $type 1 end] ;# @package -> package if {[dict exists $opt_override $type]} { @@ -2715,6 +2766,10 @@ tcl::namespace::eval punk::args { variable id_cache_rawdef tcl::dict::exists $id_cache_rawdef $id } + proc aliases {} { + variable aliases + punk::lib::showdict $aliases + } proc set_alias {alias id} { variable aliases dict set aliases $alias $id @@ -3077,62 +3132,80 @@ tcl::namespace::eval punk::args { "Ordinal index or name of command form" }] ] - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } + variable arg_error_CLR array set arg_error_CLR {} - set arg_error_CLR(errormsg) [a+ brightred] - set arg_error_CLR(title) "" - set arg_error_CLR(check) [a+ brightgreen] - set arg_error_CLR(solo) [a+ brightcyan] - set arg_error_CLR(choiceprefix) [a+ underline] - set arg_error_CLR(badarg) [a+ brightred] - set arg_error_CLR(goodarg) [a+ green strike] - set arg_error_CLR(goodchoice) [a+ reverse] - set arg_error_CLR(linebase_header) [a+ white] - set arg_error_CLR(cmdname) [a+ brightwhite] - set arg_error_CLR(groupname) [a+ bold] - set arg_error_CLR(ansiborder) [a+ bold] - set arg_error_CLR(ansibase_header) [a+ bold] - set arg_error_CLR(ansibase_body) [a+ white] variable arg_error_CLR_nocolour array set arg_error_CLR_nocolour {} - set arg_error_CLR_nocolour(errormsg) [a+ bold] - set arg_error_CLR_nocolour(title) [a+ bold] - set arg_error_CLR_nocolour(check) "" - set arg_error_CLR_nocolour(solo) "" - set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment - set arg_error_CLR_nocolour(goodarg) [a+ strike] - set arg_error_CLR_nocolour(cmdname) [a+ bold] - set arg_error_CLR_nocolour(linebase_header) "" - set arg_error_CLR_nocolour(linebase) "" - set arg_error_CLR_nocolour(ansibase_body) "" variable arg_error_CLR_info array set arg_error_CLR_info {} - set arg_error_CLR_info(errormsg) [a+ brightred bold] - set arg_error_CLR_info(title) [a+ brightyellow bold] - set arg_error_CLR_info(check) [a+ brightgreen bold] - set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_info(groupname) [a+ cyan bold] - set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] - set arg_error_CLR_info(ansibase_header) [a+ cyan] - set arg_error_CLR_info(ansibase_body) [a+ white] variable arg_error_CLR_error array set arg_error_CLR_error {} - set arg_error_CLR_error(errormsg) [a+ brightred bold] - set arg_error_CLR_error(title) [a+ brightcyan bold] - set arg_error_CLR_error(check) [a+ brightgreen bold] - set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_error(groupname) [a+ cyan bold] - set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] - set arg_error_CLR_error(ansibase_header) [a+ yellow] - set arg_error_CLR_error(ansibase_body) [a+ white] + + proc _argerror_load_colours {} { + variable arg_error_CLR + #todo - option for reload/retry? + if {[array size arg_error_CLR] > 0} { + return + } + + if {[catch {package require punk::ansi} errMsg]} { + puts stderr "punk::args FAILED to load punk::ansi\n$errMsg" + proc ::punk::args::a {args} {} + proc ::punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + #array set arg_error_CLR {} + set arg_error_CLR(errormsg) [a+ brightred] + set arg_error_CLR(title) "" + set arg_error_CLR(check) [a+ brightgreen] + set arg_error_CLR(solo) [a+ brightcyan] + set arg_error_CLR(choiceprefix) [a+ underline] + set arg_error_CLR(badarg) [a+ brightred] + set arg_error_CLR(goodarg) [a+ green strike] + set arg_error_CLR(goodchoice) [a+ reverse] + set arg_error_CLR(linebase_header) [a+ white] + set arg_error_CLR(cmdname) [a+ brightwhite] + set arg_error_CLR(groupname) [a+ bold] + set arg_error_CLR(ansiborder) [a+ bold] + set arg_error_CLR(ansibase_header) [a+ bold] + set arg_error_CLR(ansibase_body) [a+ white] + variable arg_error_CLR_nocolour + #array set arg_error_CLR_nocolour {} + set arg_error_CLR_nocolour(errormsg) [a+ bold] + set arg_error_CLR_nocolour(title) [a+ bold] + set arg_error_CLR_nocolour(check) "" + set arg_error_CLR_nocolour(solo) "" + set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment + set arg_error_CLR_nocolour(goodarg) [a+ strike] + set arg_error_CLR_nocolour(cmdname) [a+ bold] + set arg_error_CLR_nocolour(linebase_header) "" + set arg_error_CLR_nocolour(linebase) "" + set arg_error_CLR_nocolour(ansibase_body) "" + variable arg_error_CLR_info + #array set arg_error_CLR_info {} + set arg_error_CLR_info(errormsg) [a+ brightred bold] + set arg_error_CLR_info(title) [a+ brightyellow bold] + set arg_error_CLR_info(check) [a+ brightgreen bold] + set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_info(groupname) [a+ cyan bold] + set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] + set arg_error_CLR_info(ansibase_header) [a+ cyan] + set arg_error_CLR_info(ansibase_body) [a+ white] + variable arg_error_CLR_error + #array set arg_error_CLR_error {} + set arg_error_CLR_error(errormsg) [a+ brightred bold] + set arg_error_CLR_error(title) [a+ brightcyan bold] + set arg_error_CLR_error(check) [a+ brightgreen bold] + set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_error(groupname) [a+ cyan bold] + set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] + set arg_error_CLR_error(ansibase_header) [a+ yellow] + set arg_error_CLR_error(ansibase_body) [a+ white] + } #bas ic recursion blocker @@ -3174,6 +3247,8 @@ tcl::namespace::eval punk::args { error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" } + _argerror_load_colours + if {[llength $args] %2 != 0} { error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" } @@ -4579,37 +4654,61 @@ tcl::namespace::eval punk::args { #set v [lindex $values end-$ridx] set v [lindex $all_remaining end] set tp [lindex $typelist 0] + # ----------------- + set tp [string trim $tp ?] ;#shouldn't be necessary #review - ignore ?literal? and ?literal(xxx)? when clause-length == 1? (should raise error during definition instead? #we shouldn't have an optional clause member if there is only one member - the whole name should be marked -optional true instead. - set tp [string trim $tp ?] - foreach tp_member [split $tp |] { - switch -glob $tp { - literal* { + # ----------------- + + #todo - support complex type members such as -type {{literal a|b} int OR} + #for now - require llength 1 - simple type such as -type {literal(ab)|int} + if {[llength $tp] !=1} { + error "_get_dict_can_assign_value: complex -type not yet supported (tp:'$tp')" + } + + #foreach tp_alternative [split $tp |] {} + foreach tp_alternative [_split_type_expression $tp] { + switch -exact -- [lindex $tp_alternative 0] { + literal { set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx) - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #plain "literal" without bracketed specifier - match to argument name - set match $clausename - } + set match [lindex $tp_alternative 1] if {$v eq $match} { set alloc_ok 1 - lpop all_remaining + #lpop all_remaining + ledit all_remaining end end if {![dict get $ARG_INFO $clausename -multiple]} { - lpop tailnames + #lpop tailnames + ledit tailnames end end } #the type (or one of the possible type alternates) matched a literal break } } - "stringprefix(*" { - set pfx [string range $tp 13 end-1] + stringstartswith { + set pfx [lindex $tp_alternative 1] if {[string match "$pfx*" $v} { set alloc_ok 1 set alloc_ok 1 - lpop all_remaining + #lpop all_remaining + ledit all_remaining end end + if {![dict get $ARG_INFO $clausename -multiple]} { + #lpop tailnames + ledit tailnames end end + } + break + } + + } + stringendswith { + set sfx [lindex $tp_alternative 1] + if {[string match "*$sfx" $v} { + set alloc_ok 1 + set alloc_ok 1 + #lpop all_remaining + ledit all_remaining end end if {![dict get $ARG_INFO $clausename -multiple]} { - lpop tailnames + #lpop tailnames + ledit tailnames end end } break } @@ -4673,15 +4772,13 @@ tcl::namespace::eval punk::args { } } } - "stringprefix(*" { - set pfx [string range $tp 13 end-1] + "stringstartswith(*" { + set pfx [string range $tp 17 end-1] if {[string match "$pfx*" $tp]} { set alloc_ok 1 incr alloc_count } else { - if {$clause_member_optional} { - # - } else { + if {!$clause_member_optional} { set alloc_ok 0 break } @@ -4725,7 +4822,8 @@ tcl::namespace::eval punk::args { set all_remaining [lrange $all_remaining 0 end-$alloc_count] #don't lpop if -multiple true if {![dict get $ARG_INFO $clausename -multiple]} { - lpop tailnames + #lpop tailnames + ledit tailnames end end } } else { break @@ -4769,51 +4867,39 @@ tcl::namespace::eval punk::args { set member_satisfied 0 #----------------------------------------------------------------------------------- - #first build category lists of any literal,literalprefix,stringprefix,other + #first build category lists of any literal,literalprefix,stringstartwith,other # set ctg_literals [list] set ctg_literalprefixes [list] - set ctg_stringprefixes [list] + set ctg_stringstartswith [list] set ctg_other [list] - set dict_member_match [dict create] - foreach tp_member [split $tp |] { + #foreach tp_alternative [split $tp |] {} + foreach tp_alternative [_split_type_expression $tp] { #JJJJ - switch -glob -- $tp_member { - literal* { - if {[string match literalprefix* $tp_member]} { - set litinfo [string range $tp_member 13 end] - if {[string match (*) $litinfo]} { - lappend ctg_literalprefixes [string range $litinfo 1 end-1] - } else { - lappend ctg_literalprefixes $membername - } - dict set dict_member_match $tp_member [lindex $ctg_literalprefixes end] - } else { - set litinfo [string range $tp_member 7 end] - if {[string match (*) $litinfo]} { - lappend ctg_literals [string range $litinfo 1 end-1] - } else { - lappend ctg_literals $membername - } - dict set dict_member_match $tp_member [lindex $ctg_literals end] - } + switch -exact -- [lindex $tp_alternative 0] { + literal { + set litinfo [lindex $tp_alternative 1] + lappend ctg_literals $litinfo } - "stringprefix(*" { - set pfx [string range $tp_member 13 end-1] - lappend ctg_stringprefixes $pfx + literalprefix { + set litinfo [lindex $tp_alternative 1] + lappend ctg_literalprefixes $litinfo + } + stringstartswith { + set pfx [lindex $tp_alternative 1] + lappend ctg_stringstartswith $pfx } default { - lappend ctg_other $tp_member + lappend ctg_other $tp_alternative } } } #----------------------------------------------------------------------------------- - #asert - each tp_member is a key in dict_member_match if {[llength $ctg_other] > 0} { #presence of any ordinary type as one of the alternates - means we consider it a match if certain basic types align #we don't do full validation here -leave main validation for later (review) - foreach tp_member $ctg_other { - switch -exact -- $tp_member { + foreach tp_alternative $ctg_other { + switch -exact -- $tp_alternative { int { if {[string is integer -strict $v]} { set member_satisfied 1 @@ -4860,16 +4946,17 @@ tcl::namespace::eval punk::args { } else { #ctg_literals is included in the prefix-calc - but a shortened version of an entry in literals is not allowed #(exact match would have been caught in other branch of this if) - #review - how does ctg_stringprefixes affect prefix calc for literals? + #review - how does ctg_stringstartswith affect prefix calc for literals? set full_v [tcl::prefix::match -error "" [list {*}$ctg_literals {*}$ctg_literalprefixes] $v] if {$full_v ne "" && $full_v ni $ctg_literals} { #matched prefix must be for one of the entries in ctg_literalprefixes - valid set member_satisfied 1 + set v $full_v ;#map prefix given as arg to the full literalprefix value } } } - if {!$member_satisfied && [llength $ctg_stringprefixes]} { - foreach pfx $ctg_stringprefixes { + if {!$member_satisfied && [llength $ctg_stringstartswith]} { + foreach pfx $ctg_stringstartswith { if {[string match "$pfx*" $v]} { set member_satisfied 1 break @@ -4877,28 +4964,6 @@ tcl::namespace::eval punk::args { } } - #foreach tp_member [split $tp |] { - # if {[string match literal* $tp_member]} { - # #todo - support literal prefix-matching - # #e.g see ::readFile filename ?text|binary? - must accept something like readfile xxx.txt b - # set litinfo [string range $tp_member 7 end] - # if {[string match (*) $litinfo]} { - # set match [string range $litinfo 1 end-1] - # } else { - # set match $membername - # } - # set match [dict get $dict_member_match $tp_member] - # if {$v eq $match} { - # set member_satisfied 1 - # break - # } - # } else { - # #we don't validate here -leave validation for later (review) - # set member_satisfied 1 - # break - # } - #} - if {$member_satisfied} { if {$clause_member_optional && $alloc_count >= [llength $all_remaining]} { if {[dict exists $ARG_INFO $thisname -typedefaults]} { @@ -4949,6 +5014,1207 @@ tcl::namespace::eval punk::args { return $d } + #_split_type_expression + #only handles toplevel 'or' for type_expression e.g int|char + #we have no mechanism for & - (although it would be useful) + #more complex type_expressions would require a bracketing syntax - (and probably pre-parsing) + #or perhaps more performant, RPN to avoid bracket parsing + #if literal(..), literalprefix(..), stringstartswith(..) etc can have pipe symbols and brackets etc - we can't just use split + #if we require -type to always be treated as a list - and if an element is length 1 - require it to + #have properly balanced brackets that don't contain | ( ) etc we can simplify - REVIEW + + #consider: + #1 basic syntax - only OR supported - limits on what chars can be put in 'textn' elements. + #mode -type literalprefix(text1)|literalprefix(text2) -optional 1 + #2 expanded syntax - supports arbitrary chars in 'textn' elements - but still doesn't support more complex OR/AND logic + #mode -type {{literalprefix text1 | literalprefix text2}} + #3 RPN (reverse polish notation) - somewhat unintuitive, but allows arbitrary textn, and complex OR/AND logic without brackets. + #(forth like - stack based definition of types) + #mode -type {literalprefix text1 literalprefix text2 OR} + #mode -type {stringstartswith x stringstartswith y OR stringendswith z AND int OR} + + proc _split_type_expression {type_expression} { + if {[llength $type_expression] == 1} { + #simple expressions of length one must be splittable on | + #disallowed: things such as literal(|) or literal(x|etc)|int + #these would have to be expressed as {literal |} and {literal x|etc | int} + set or_type_parts [split $type_expression |] + set type_alternatives [list] + foreach t $or_type_parts { + if {[regexp {([^\(^\)]*)\((.*)\)$} $t _ name val]} { + lappend type_alternatives [list $name $val] + } else { + lappend type_alternatives $t + } + } + return $type_alternatives + } else { + error "_split_type_expression unimplemented: type_expression length > 1 '$type_expression'" + #todo + #RPN reverse polish notation + #e.g {stringstartswith x stringstartswith y OR stringendswith z AND int OR} + #equivalent logic: ((stringstartswith(x)|stringstartswith(y))&stringendswith(z))|int + # {int ; stringstartswith x stringstartswith y OR } + + #experimental.. seems like a pointless syntax. + #may as well just use list of lists with |(or) as the intrinsic operator instead of parsing this + #e.g {stringstartswith x | literal | | int} + set type_alternatives [list] + set expect_separator 0 + for {set w 0} {$w < [llength $type_expression]} {incr w} { + set word [lindex $type_expression $w] + if {$expect_separator} { + if {$word eq "|"} { + #pipe could be last entry - not strictly correct, but can ignore + set expect_separator 0 + continue + } else { + error "_split_type_expression expected separator but received '$word' in type_expression:'$type_expression'" + } + } + switch -exact -- $word { + literal - literalprefix - stringstartswith - stringendswith - stringcontains { + if {$w+1 > [llength $type_expression]} { + #premature end - no arg available for type which requires one + error "_split_type_expression missing argument for type '$word' in type_expression:'$type_expression'" + } + lappend type_alternatives [list $word [lindex $type_expression $w+1]] + incr w ;#consume arg + set expect_separator 1 + } + default { + #simple types such as int,double,string + lappend type_alternatives $word + set expect_separator 1 + } + } + } + return $type_alternatives + } + } + + #old version + proc _check_clausecolumn {argname argclass thisarg thisarg_checks clausecolumn type_expression clausevalues_raw clausevalues_check argspecs} { + #set type $type_expression ;#todo - 'split' on | + set vlist $clausevalues_raw + set vlist_check $clausevalues_check + + set type_alternatives [_split_type_expression $type_expression] + #each type_alternative is a list of varying length depending on arguments supported by first word. + #TODO? + #single element types: int double string etc + #two element types literal literalprefix stringstartswith stringendswith + #TODO + set stype [lindex $type_alternatives 0] + #e.g int + #e.g {literal blah)etc} + set type [lindex $stype 0] + #switch on first word of each stype + # + + #review - for leaders,values - do we need to check literal etc? already checked during split into prevalues postvalues ? + switch -- $type { + any {} + literal { + foreach clauseval $vlist { + set e [lindex $clauseval $clausecolumn] + set testval [lindex $stype 1] + if {$e ne $testval} { + set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + stringstartwith { + foreach clauseval $vlist { + set e [lindex $clauseval $clausecolumn] + set testval [lindex $stype 1] + if {![string match $testval* $e]} { + set msg "$argclass '$argname' for %caller% requires stringstartswith value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + list { + foreach clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $clausecolumn] + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + indexexpression { + foreach clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $clausecolumn] + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + if {$regexprepass ne ""} { + foreach clauseval $vlist clauseval_check $vlist_check { + set e [lindex $clauseval $clausecolumn] + set e_check [lindex $clauseval_check $clausecolumn] + if {[regexp [lindex $regexprepass $clausecolumn] $e]} { + lappend pass_quick_list_e $clauseval + lappend pass_quick_list_e_check $clauseval_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach clauseval $remaining_e clauseval_check $remaining_e_check { + set e [lindex $clauseval $clausecolumn] + set e_check [lindex $clauseval_check $clausecolumn] + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach clauseval $remaining_e { + set e [lindex $clauseval $clausecolumn] + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach clauseval $remaining_e { + set e [lindex $clauseval $clausecolumn] + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach clauseval $remaining_e_check { + set e_check [lindex $clauseval $clausecolumn] + if {[dict exists $thisarg_checks -minsize]} { + set minsize [dict get $thisarg_checks -minsize] + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $minsize} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {[dict exists $thisarg_checks -maxsize]} { + set maxsize [dict get $thisarg_checks -maxsize] + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $maxsize} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) + foreach clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $clausecolumn] + if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {[tcl::dict::exists $thisarg -typeranges]} { + set ranges [tcl::dict::get $thisarg -typeranges] + foreach clauseval $vlist clauseval_check $vlist_check { + set e [lindex $clauseval $clausecolumn] + set e_check [lindex $clauseval_check $clausecolumn] + set range [lindex $ranges $clausecolumn] + lassign {} low high ;#set both empty + lassign $range low high + + if {"$low$high" ne ""} { + if {[::tcl::mathfunc::isnan $e]} { + set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + int { + #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + foreach clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $clausecolumn] + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {[tcl::dict::exists $thisarg -typeranges]} { + set ranges [tcl::dict::get $thisarg -typeranges] + foreach clauseval $vlist clauseval_check $vlist_check { + set e [lindex $clauseval $clausecolumn] + set e_check [lindex $clauseval_check $clausecolumn] + set range [lindex $ranges $clausecolumn] + lassign $range low high + if {"$low$high" ne ""} { + if {$low eq ""} { + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } elseif {$high eq ""} { + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } else { + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + double { + foreach clauseval $vlist clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $clausecolumn] + if {![tcl::string::is double -strict $e_check]} { + set e [lindex $clauseval $clausecolumn] + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {[tcl::dict::size $thisarg_checks]} { + if {[dict exists $thisarg_checks -typeranges]} { + set ranges [dict get $thisarg_checks -typeranges] + foreach clauseval $vlist clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $clausecolumn] + set range [lindex $ranges $clausecolumn] + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $range low high + if {$e_check < $low || $e_check > $high} { + set e [lindex $clauseval $clausecolumn] + set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + bool { + foreach clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $clausecolumn] + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $clausecolumn] + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + if {[tcl::dict::size $thisarg_checks]} { + if {[dict exists $thisarg_checks -minsize]} { + set minsizes [dict get $thisarg_checks -minsize] + foreach clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $clausecolumn] + set minsize [lindex $minsizes $clausecolumn] + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $minsize} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + if {[dict exists $thisarg_checks -maxsize]} { + set maxsizes [dict get $thisarg_checks -maxsize] + foreach clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $clausecolumn] + set maxsize [lindex $maxsizes $clausecolumn] + if {$maxsize ne "-1"} { + if {[tcl::dict::size $e_check] > $maxsize} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach clauseval $vlist clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $clausecolumn] + if {![tcl::string::is $type -strict $e_check]} { + set e [lindex $clauseval $t] + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach clauseval $vlist clauseval_check $vlist_check { + set e [lindex $clauseval $clausecolumn] + set e_check [lindex $clauseval_check $clausecolumn] + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$type eq "existingfile"} { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } elseif {$type eq "existingdirectory"} { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach clauseval $vlist clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $clausecolumn] + if {[tcl::string::length $e_check] != 1} { + set e [lindex $clauseval $clausecolumn] + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + default { + } + } + + } + + #new version + proc _check_clausecolumn2 {argname argclass thisarg thisarg_checks clausecolumn type_expression clausevalues_raw clausevalues_check argspecs} { + #puts "--->checking arg:$argname checkvalue:[lindex $clausevalues_check $clausecolumn] against type_expression $type_expression" + set vlist [list] + set cidx -1 + foreach cv $clausevalues_raw { + incr cidx + lappend vlist [list $cidx $cv] ;#store the index so we can reduce vlist as we go + } + set vlist_check [list] + set cidx -1 + foreach cv $clausevalues_check { + incr cidx + lappend vlist_check [list $cidx $cv] + } + + set type_alternatives [_split_type_expression $type_expression] + #each type_alternative is a list of varying length depending on arguments supported by first word. + #TODO? + #single element types: int double string etc + #two element types literal literalprefix stringstartswith stringendswith + #TODO + + #list for each clause (each clause is itself a list - usually length 1 but can be any length - we are dealing only with one column of the clauses) + set clause_results [lrepeat [llength $clausevalues_raw] [lrepeat [llength $type_alternatives] _]] + #e.g for clause_values_raw {{a b c} {1 2 3}} when clausecolumn is 0 + #-types {int|char|literal(ok) char double} + #we are checking a and 1 against the type_expression int|char|literal(ok) (type_alternatives = {int char literal(ok)} + #our initial clause_results in this case is a 2x2 list {{_ _ _} {_ _ _}} + # + + + set a_idx -1 + foreach atype $type_alternatives { + incr a_idx + #set atype [lindex $type_alternatives 0] + #e.g int + #e.g {literal blah} + + + set type [lindex $atype 0] + #switch on first word of each atype + # + + #review - for leaders,values - do we need to check literal etc? already checked during split into prevalues postvalues ? + switch -- $type { + any {} + literal { + foreach idx_clauseval $vlist { + lassign $idx_clauseval c_idx clauseval + set e [lindex $clauseval $clausecolumn] + set testval [lindex $atype 1] + if {$e ne $testval} { + set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] + } else { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx ;#this clause is satisfied - no need to process it for other atypes + ledit vlist_check $c_idx $c_idx + } + } + } + literalprefix { + set alt_literals [lsearch -all -inline -index 0 $type_alternatives literal] + set literals [lmap v $alt_literals {lindex $v 1}] + set alt_literalprefixes [lsearch -all -inline -index 0 $type_alternatives literalprefix] + set literalprefixes [lmap v $alt_literalprefixes {lindex $v 1}] + + foreach idx_clauseval $vlist { + lassign $idx_clauseval c_idx clauseval + set e [lindex $clauseval $clausecolumn] + #this specific literalprefix value not relevant - we're testing against all in the set of typealternates + #set testval [lindex $atype 1] + set match [::tcl::prefix::match -error "" [list {*}$literals {*}$literalprefixes] $e] + if {$match ne "" && $match ni $literals} { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx ;#this clause is satisfied - no need to process it for other atypes + ledit vlist_check $c_idx $c_idx + } else { + set msg "$argclass '$argname' for %caller% requires unambiguous literal prefix match for one of '$literalprefixes' within prefix calculation set:'[list {*}$literals {*}$literalprefixes]'. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] + } + } + } + stringstartswith { + foreach idx_clauseval $vlist { + lassign $idx_clauseval c_idx clauseval + set e [lindex $clauseval $clausecolumn] + set testval [lindex $atype 1] + if {[string match $testval* $e]} { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } else { + set msg "$argclass '$argname' for %caller% requires stringstartswith value '$testval'. Received: '$e'" + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] + } + } + } + stringendswith { + foreach idx_clauseval $vlist { + lassign $idx_clauseval c_idx clauseval + set e [lindex $clauseval $clausecolumn] + set testval [lindex $atype 1] + if {[string match *$testval $e]} { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } else { + set msg "$argclass '$argname' for %caller% requires stringendswith value '$testval'. Received: '$e'" + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] + } + } + } + list { + foreach idx_clauseval_check $vlist_check { + lassign $idx_clauseval_check c_idx clauseval_check + set e_check [lindex $clauseval_check $clausecolumn] + set passed_checks 1 + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs] msg $msg] + set passed_checks 0 + } else { + if {[dict exists $thisarg_checks -minsize]} { + # -1 for disable is as good as zero + set minsize [dict get $thisarg_checks -minsize] + if {[llength $e_check] < $minsize} { + set msg "$argclass '$argname for %caller% requires list with -minsize $minsize. Received len:[llength $e_check]" + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } + if {$passed_checks && [dict exist $thisarg_checks -maxsize]} { + set maxsize [dict get $thisarg_checks -maxsize] + if {$maxsize ne "-1"} { + if {[llength $e_check] > $maxsize} { + set msg "$argclass '$argname for %caller% requires list with -maxsize $maxsize. Received len:[llength $e_check]" + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } + } + } + if {$passed_checks} { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } + indexexpression { + foreach idx_clauseval_check $vlist_check { + lassign $idx_clauseval_check c_idx clauseval_check + set e_check [lindex $clauseval_check $clausecolumn] + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + } else { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + #REVIEW we only have a single regexprepass/regexprefail for entire typeset?? need to make it a list like -typedefaults? + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + if {$regexprepass ne ""} { + foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { + lassign $idx_clauseval c_idx clauseval + lassign $idx_clauseval_check _ clauseval_check + set e [lindex $clauseval $clausecolumn] + set e_check [lindex $clauseval_check $clausecolumn] + if {[regexp [lindex $regexprepass $clausecolumn] $e]} { + #lappend pass_quick_list_e [list $c_idx $clauseval] + #lappend pass_quick_list_e_check [list $c_idx $clauseval_check] + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + #set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + #set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { + lassign $idx_clauseval c_idx clauseval + lassign $idx_clauseval_check _ clauseval_check + + set e [lindex $clauseval $clausecolumn] + set e_check [lindex $clauseval_check $clausecolumn] + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs] msg $msg] + #review - tests? + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach idx_clauseval $vlist { + lassign $idx_clauseval c_idx clauseval + if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + continue + } + set e [lindex $clauseval $clausecolumn] + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + } + } + } + globstring { + foreach idx_clauseval $vlist { + lassign $idx_clauseval c_idx clauseval + if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + continue + } + set e [lindex $clauseval $clausecolumn] + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + } + } + } + } + + foreach idx_clauseval_check $vlist_check { + lassign $idx_clauseval_check c_idx clauseval_check + if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + continue + } + if {[tcl::dict::size $thisarg_checks]} { + set passed_checks 1 + set e_check [lindex $clauseval_check $clausecolumn] + if {[dict exists $thisarg_checks -minsize]} { + set minsize [dict get $thisarg_checks -minsize] + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $minsize} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } + if {$passed_checks && [dict exists $thisarg_checks -maxsize]} { + set maxsize [dict get $thisarg_checks -maxsize] + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $maxsize} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } + } + if {$passed_checks} { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } else { + if {[lindex $clause_results $c_idx $a_idx] eq "_"} { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } + } + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) + foreach idx_clauseval_check $vlist_check { + lassign $idx_clauseval_check c_idx clauseval_check + set e_check [lindex $clauseval_check $clausecolumn] + if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + } + } + if {[tcl::dict::exists $thisarg -typeranges]} { + set ranges [tcl::dict::get $thisarg -typeranges] + foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { + lassign $idx_clauseval c_idx clauseval + lassign $idx_clauseval_check __ clauseval_check + if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + continue + } + set e [lindex $clauseval $clausecolumn] + set e_check [lindex $clauseval_check $clausecolumn] + set range [lindex $ranges $clausecolumn] + lassign {} low high ;#set both empty + lassign $range low high + set passed_checks 1 + if {"$low$high" ne ""} { + if {[::tcl::mathfunc::isnan $e]} { + set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + if {$passed_checks} { + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } + } + } + if {$passed_checks} { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } else { + foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { + lassign $idx_clauseval c_idx clauseval + lassign $idx_clauseval_check __ clauseval_check + if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + continue + } + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + + } + int { + #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + foreach idx_clauseval_check $vlist_check { + lassign $idx_clauseval_check c_idx clauseval_check + set e_check [lindex $clauseval_check $clausecolumn] + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + } + } + if {[tcl::dict::exists $thisarg -typeranges]} { + set ranges [tcl::dict::get $thisarg -typeranges] + foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { + lassign $idx_clauseval c_idx clauseval + lassign $idx_clauseval_check c_idx clauseval_check + if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + continue + } + set e [lindex $clauseval $clausecolumn] + set e_check [lindex $clauseval_check $clausecolumn] + set range [lindex $ranges $clausecolumn] + lassign $range low high + set passed_checks 1 + if {"$low$high" ne ""} { + if {$low eq ""} { + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } elseif {$high eq ""} { + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } else { + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } + } + if {$passed_checks} { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } else { + foreach idx_clauseval $vlist { + lassign $idx_clauseval c_idx clauseval + if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + continue + } + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } + double { + foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { + lassign $idx_clauseval c_idx clauseval + lassign $idx_clauseval_check c_idx clauseval_check + set e_check [lindex $clauseval_check $clausecolumn] + if {![tcl::string::is double -strict $e_check]} { + set e [lindex $clauseval $clausecolumn] + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + } + } + if {[tcl::dict::exists $thisarg_checks -typeranges]} { + set ranges [dict get $thisarg_checks -typeranges] + foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { + lassign $idx_clauseval c_idx clauseval + lassign $idx_clauseval_check c_idx clauseval_check + if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + continue + } + set e_check [lindex $clauseval_check $clausecolumn] + set range [lindex $ranges $clausecolumn] + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + set passed_checks 1 + lassign $range low high + if {$low$high ne ""} { + if {$e_check < $low || $e_check > $high} { + set e [lindex $clauseval $clausecolumn] + set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } + if {$passed_checks} { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } else { + foreach idx_clauseval $vlist { + lassign $idx_clauseval c_idx clauseval + if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + continue + } + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } + bool { + foreach idx_clauseval_check $vlist_check { + lassign $idx_clauseval_check c_idx clauseval_check + set e_check [lindex $clauseval_check $clausecolumn] + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + } else { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } + dict { + foreach idx_clauseval_check $vlist_check { + lassign $idx_clauseval_check c_idx clauseval_check + set e_check [lindex $clauseval_check $clausecolumn] + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] + } + } + foreach idx_clauseval_check $vlist_check { + lassign $idx_clauseval_check c_idx clauseval_check + if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + continue + } + set passed_checks 1 + if {[tcl::dict::size $thisarg_checks]} { + if {[dict exists $thisarg_checks -minsize]} { + set minsizes [dict get $thisarg_checks -minsize] + set e_check [lindex $clauseval_check $clausecolumn] + set minsize [lindex $minsizes $clausecolumn] + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $minsize} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } + if {$passed_checks && [dict exists $thisarg_checks -maxsize]} { + set e_check [lindex $clauseval_check $clausecolumn] + set maxsize [lindex $maxsizes $clausecolumn] + if {$maxsize ne "-1"} { + if {[tcl::dict::size $e_check] > $maxsize} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } + } + } + + if {$passed_checks} { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { + lassign $idx_clauseval c_idx clauseval + lassign $idx_clauseval_check c_idx clauseval_check + set e_check [lindex $clauseval_check $clausecolumn] + if {![tcl::string::is $type -strict $e_check]} { + set e [lindex $clauseval $t] + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + } else { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { + lassign $idx_clauseval c_idx clauseval + lassign $idx_clauseval_check c_idx clauseval_check + + set e [lindex $clauseval $clausecolumn] + set e_check [lindex $clauseval_check $clausecolumn] + + #//review - we may need '?' char on windows + set passed_checks 1 + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + if {$passed_checks} { + if {$type eq "existingfile"} { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } elseif {$type eq "existingdirectory"} { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } + } + if {$passed_checks} { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { + lassign $idx_clauseval c_idx clauseval + lassign $idx_clauseval_check c_idx clauseval_check + + set e_check [lindex $clauseval_check $clausecolumn] + if {[tcl::string::length $e_check] != 1} { + set e [lindex $clauseval $clausecolumn] + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] + } else { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } + tk_screen_units { + foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { + lassign $idx_clauseval c_idx clauseval + lassign $idx_clauseval_check c_idx clauseval_check + + set e_check [lindex $clauseval_check $clausecolumn] + set passed_checks 1 + switch -exact -- [string index $e_check end] { + c - i - m - p { + set numpart [string range $e_check 0 end-1] + if {![tcl::string::is double $numpart]} { + set e [lindex $clauseval $clausecolumn] + set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels." + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } + default { + if {![tcl::string::is double $e_check]} { + set e [lindex $clauseval $clausecolumn] + set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels." + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] + set passed_checks 0 + } + } + } + if {$passed_checks} { + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } + default { + #default pass for unrecognised types - review. + foreach idx_clauseval $vlist { + lassign $idx_clauseval c_idx clauseval + lset clause_results $c_idx $a_idx 1 + ledit vlist $c_idx $c_idx + ledit vlist_check $c_idx $c_idx + } + } + } + } + foreach clauseresult $clause_results { + if {[lsearch $clauseresult 1] == -1} { + #no pass for this clause - fetch first? error and raise + #todo - return error containing clause_indices so we can report more than one failing element at once? + foreach e $clauseresult { + if {[lindex $e 0] eq "errorcode"} { + #errorcode msg =0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { @@ -5788,8 +7057,8 @@ tcl::namespace::eval punk::args { } } else { #not a flag/option - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] break } } @@ -5974,7 +7243,8 @@ tcl::namespace::eval punk::args { } if {[llength $leadertypelist] == 1} { - set clauseval $ldr + #set clauseval $ldr + set clauseval [lindex $resultlist 0] } else { set clauseval $resultlist incr ldridx [expr {$consumed - 1}] @@ -6036,7 +7306,19 @@ tcl::namespace::eval punk::args { } #----------------------------------------------------- #satisfy test parse_withdef_leaders_no_phantom_default - foreach leadername [dict keys $leaders_dict] { + #foreach leadername [dict keys $leaders_dict] { + # if {[string is integer -strict $leadername]} { + # #ignore leadername that is a positionalidx + # #review - always trailing - could use break? + # continue + # } + # if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { + # #remove the name with empty-string default we used to establish fixed order of names + # #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. + # dict unset leaders_dict $leadername + # } + #} + dict for {leadername _v} $leaders_dict { if {[string is integer -strict $leadername]} { #ignore leadername that is a positionalidx #review - always trailing - could use break? @@ -6109,7 +7391,8 @@ tcl::namespace::eval punk::args { #assert can_assign != 0, we have at least one value to assign to clause if {[llength $valtypelist] == 1} { - set clauseval $val + #set clauseval $val + set clauseval [lindex $resultlist 0] } else { #clauseval must contain as many elements as the max length of -types! #(empty-string/default for optional (?xxx?) clause members) @@ -6341,8 +7624,6 @@ tcl::namespace::eval punk::args { } set typelist [tcl::dict::get $thisarg -type] set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 set validationtransform [tcl::dict::get $thisarg -validationtransform] @@ -6389,6 +7670,8 @@ tcl::namespace::eval punk::args { set argclass "Unknown argument" } } + set vlist_validate [list] + set vlist_check_validate [list] #reduce our validation requirements by removing values which match defaultval or match -choices #(could be -multiple with -choicerestricted 0 where some selections match and others don't) if {$api_argname in $receivednames && $has_choices} { @@ -6420,9 +7703,11 @@ tcl::namespace::eval punk::args { #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes #assert llength $vlist == llength [dict get $dname $argname] # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { + #J2 + #set vlist_validate [list] + #set vlist_check_validate [list] + foreach clause $vlist clause_check $vlist_check { + foreach e $clause e_check $clause_check { set allchoices_in_list 0 if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { #vlist and vlist_check can be list of lists if -multiple and -choicemultiple @@ -6587,6 +7872,7 @@ tcl::namespace::eval punk::args { incr idx } + } #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups set vlist $vlist_validate @@ -6600,30 +7886,45 @@ tcl::namespace::eval punk::args { set vlist_check_validate [list] } else { if {[llength $vlist] && $has_default} { - #defaultval here is a value for the clause. - set vlist_validate [list] - set vlist_check_validate [list] + #defaultval here is a value for the entire clause. (clause usually length 1) + #J2 + #set vlist_validate [list] + #set vlist_check_validate [list] + set tp [dict get $thisarg -type] foreach clause_value $vlist clause_check $vlist_check { #JJJJ - #argname - #thisarg - set tp [dict get $thisarg -type] - if {[llength $tp] == 1} { - if {$clause_value ni $vlist_validate} { - #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$clause_value ni $vlist_validate} { + if {[llength $tp] ==1} { + #for -choicemultiple with default that could be a list use 'ni' + #?? review! if {[lindex $clause_check 0] ne $defaultval} { - lappend vlist_validate $clause_value - lappend vlist_check_validate $clause_check + lappend vlist_validate $clause_value + lappend vlist_check_validate $clause_check } - } - } else { - if {$clause_value ni $vlist_validate} { + } else { if {$clause_check ne $defaultval} { - lappend vlist_validate $clause_value - lappend vlist_check_validate $clause_check + lappend vlist_validate $clause_value + lappend vlist_check_validate $clause_check } } } + #if {[llength $tp] == 1} { + # if {$clause_value ni $vlist_validate} { + # #for -choicemultiple with default that could be a list use 'ni' + # #?? review! + # if {[lindex $clause_check 0] ne $defaultval} { + # lappend vlist_validate $clause_value + # lappend vlist_check_validate $clause_check + # } + # } + #} else { + # if {$clause_value ni $vlist_validate} { + # if {$clause_check ne $defaultval} { + # lappend vlist_validate $clause_value + # lappend vlist_check_validate $clause_check + # } + # } + #} #Todo? #else ??? } @@ -6660,373 +7961,36 @@ tcl::namespace::eval punk::args { #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups #assert [llength $vlist] == [llength $vlist_check] if {[llength $vlist]} { - for {set t 0} {$t < [llength $typelist]} {incr t} { - set typespec [lindex $typelist $t] - set type [string trim $typespec ?] - #puts "$argname - switch on type: $type" - switch -- $type { - any {} - literal { - foreach clause_value $vlist { - set e [lindex $clause_value $t] - if {$e ne $argname} { - set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - list { - foreach clause_value $vlist_check { - set e_check [lindex $clause_value $t] - if {![tcl::string::is list -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - indexexpression { - foreach clause_value $vlist_check { - set e_check [lindex $clause_value $t] - if {[catch {lindex {} $e_check}]} { - set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } + #$t = clause column + + #for {set clausecolumn 0} {$clausecolumn < [llength $typelist]} {incr clausecolumn} {} + set clausecolumn -1 + foreach typespec $typelist { + incr clausecolumn + if {[dict exists $thisarg -typedefaults]} { + set tds [dict get $thisarg -typedefaults] + if {[lindex $vlist $clausecolumn] eq [lindex $tds $clausecolumn]} { + continue } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $t] - set e_check [lindex $clauseval_check $t] - if {[regexp [lindex $regexprepass $t] $e]} { - lappend pass_quick_list_e $clauseval - lappend pass_quick_list_e_check $clauseval_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach clauseval $remaining_e clauseval_check $remaining_e_check { - set e [lindex $clauseval $t] - set e_check [lindex $clauseval_check $t] - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach clauseval $remaining_e { - set e [lindex $clauseval $t] - if {![punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - globstring { - foreach clauseval $remaining_e { - set e [lindex $clauseval $t] - if {![regexp {[*?\[\]]} $e]} { - set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } + } - if {[tcl::dict::size $thisarg_checks]} { - foreach clauseval $remaining_e_check { - set e_check [lindex $clauseval $t] - if {[dict exists $thisarg_checks -minsize]} { - set minsize [dict get $thisarg_checks -minsize] - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $minsize} { - set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[dict exists $thisarg_checks -maxsize]} { - set maxsize [dict get $thisarg_checks -maxsize] - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $maxsize} { - set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - number { - #review - consider effects of Nan and Inf - #NaN can be considered as 'technically' a number (or at least a special numeric value) - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::exists $thisarg -typeranges]} { - set ranges [tcl::dict::get $thisarg -typeranges] - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $t] - set e_check [lindex $clauseval_check $t] - set range [lindex $ranges $t] - lassign {} low high ;#set both empty - lassign $range low high - - if {"$low$high" ne ""} { - if {[::tcl::mathfunc::isnan $e]} { - set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$low eq ""} { - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } elseif {$high eq ""} { - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } else { - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - int { - #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::exists $thisarg -typeranges]} { - set ranges [tcl::dict::get $thisarg -typeranges] - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $t] - set e_check [lindex $clauseval_check $t] - set range [lindex $ranges $t] - lassign $range low high - if {"$low$high" ne ""} { - if {$low eq ""} { - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } elseif {$high eq ""} { - #highside unspecified - check only low - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } else { - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - double { - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {![tcl::string::is double -strict $e_check]} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::size $thisarg_checks]} { - if {[dict exists $thisarg_checks -typeranges]} { - set ranges [dict get $thisarg_checks -typeranges] - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - set range [lindex $ranges $t] - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $range low high - if {$e_check < $low || $e_check > $high} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - bool { - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {![tcl::string::is boolean -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - dict { - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {[llength $e_check] %2 != 0} { - set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::size $thisarg_checks]} { - if {[dict exists $thisarg_checks -minsize]} { - set minsizes [dict get $thisarg_checks -minsize] - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - set minsize [lindex $minsizes $t] - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $minsize} { - set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - if {[dict exists $thisarg_checks -maxsize]} { - set maxsizes [dict get $thisarg_checks -maxsize] - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - set maxsize [lindex $maxsizes $t] - if {$maxsize ne "-1"} { - if {[tcl::dict::size $e_check] > $maxsize} { - set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {![tcl::string::is $type -strict $e_check]} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {[tcl::string::length $e_check] != 1} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } + set type_expression [string trim $typespec ?] + if {$type_expression in {any none}} { + continue } + #puts "$argname - switch on type_expression: $type_expression v:[lindex $vlist $clausecolumn]" + #set typespec [lindex $typelist $clausecolumn] + #todo - handle type-alternates e.g -type char|double + #------------------------------------------------------------------------------------ + #_check_clausecolumn argname argclass thisarg thisarg_checks column type_expression clausevalues clausevalues_check + _check_clausecolumn2 $argname $argclass $thisarg $thisarg_checks $clausecolumn $type_expression $vlist $vlist_check $argspecs + #------------------------------------------------------------------------------------ + + + #todo - pass validation if matches an entry in -typedefaults + #has_typedefault? + #set typedefault [lindex $typedefaults $clausecolumn] + } @@ -7096,6 +8060,33 @@ tcl::namespace::eval punk::args { return [list] } } + + + lappend PUNKARGS [list { + @id -id ::punk::args::eg + @cmd -name punk::args::eg\ + -summary\ + "Command examples."\ + -help\ + "Return command examples from -help in @examples + directive of a command definition." + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc eg {args} { + set argd [punk::args::parse $args withid ::punk::args::eg] + lassign [dict values $argd] leaders opts values received + set cmditems [dict get $values cmditem] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + return [dict get $spec examples_info -help] + } + lappend PUNKARGS [list { @id -id ::punk::args::synopsis @cmd -name punk::args::synopsis\ @@ -7219,26 +8210,63 @@ tcl::namespace::eval punk::args { set typelist [dict get $arginfo -type] if {[llength $typelist] == 1} { set tp [lindex $typelist 0] - if {[dict exists $arginfo -typesynopsis]} { + set ts [Dict_getdef $arginfo -typesynopsis ""] + if {$ts ne ""} { #set arg_display [dict get $arginfo -typesynopsis] - set clause [dict get $arginfo -typesynopsis] + set clause $ts } else { #set arg_display $argname - if {$tp eq "literal"} { - set clause [lindex $argname end] - } elseif {[string match literal(*) $tp]} { - set match [string range $tp 8 end-1] - set clause $match - } else { - set clause $I$argname$NI + set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) + set type_alternatives [_split_type_expression $tp] + foreach tp_alternative $type_alternatives { + set firstword [lindex $tp_alternative 0] + switch -exact -- $firstword { + literal { + set match [lindex $tp_alternative 1] + lappend alternates $match + } + literalprefix { + #todo - trie styling on prefix calc + set match [lindex $tp_alternative 1] + lappend alternates $match + } + stringstartswith { + set match [lindex $tp_alternative 1] + lappend alternates $match* + } + stringendswith { + set match [lindex $tp_alternative 1] + lappend alternates *$match + } + default { + lappend alternates $I$argname$NI + } + } + + #if {$tp_alternative eq "literal"} { + # lappend alternates [lindex $argname end] + #} elseif {[string match literal(*) $tp_alternative]} { + # set match [string range $tp_alternative 8 end-1] + # lappend alternates $match + #} elseif {[string match literalprefix(*) $tp_alternative]} { + # set match [string range $tp_alternative 14 end-1] + # lappend alternates $match + #} else { + # lappend alternates $I$argname$NI + #} } + #remove dupes - but keep order (e.g of dupes -type string|int when no -typesynopsis was specified) + #todo - trie prefixes display + set alternates [punk::args::lib::lunique $alternates] + set clause [join $alternates |] } } else { set n [expr {[llength $typelist]-1}] set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types set clause "" - if {[dict exists $arginfo -typesynopsis]} { - set tp_displaylist [dict get $arginfo -typesynopsis] + set ts [Dict_getdef $arginfo -typesynopsis ""] + if {$ts ne ""} { + set tp_displaylist $ts } else { set tp_displaylist [lrepeat [llength $typelist] ""] } @@ -7329,8 +8357,9 @@ tcl::namespace::eval punk::args { } - if {[dict exists $arginfo -typesynopsis]} { - set tp_display [dict get $arginfo -typesynopsis] + set ts [Dict_getdef $arginfo -typesynopsis ""] + if {$ts ne ""} { + set tp_display $ts #user may or may not have remembered to match the typesynopsis with the optionality by wrapping with ? #review - if user wrapped with ?*? and also leading/trailing ANSI - we won't properly strip #todo - enforce no wrapping '?*?' in define for -typesynopsis? @@ -7338,16 +8367,16 @@ tcl::namespace::eval punk::args { } else { set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) - foreach tp_member [split $tp |] { + foreach tp_alternative [split $tp |] { #-type literal not valid for opt - review - if {[string match literal(*) $tp_member]} { - set match [string range $tp_member 8 end-1] + if {[string match literal(*) $tp_alternative]} { + set match [string range $tp_alternative 8 end-1] lappend alternates $match - } elseif {[string match literalprefix(*) $tp_member]} { - set match [string range $tp_member 14 end-1] + } elseif {[string match literalprefix(*) $tp_alternative]} { + set match [string range $tp_alternative 14 end-1] lappend alternates $match } else { - lappend alternates <$I$tp_member$NI> + lappend alternates <$I$tp_alternative$NI> } } #todo - trie prefixes display? @@ -7447,20 +8476,21 @@ tcl::namespace::eval punk::args { set typelist [dict get $arginfo -type] if {[llength $typelist] == 1} { set tp [lindex $typelist 0] - if {[dict exists $arginfo -typesynopsis]} { + set ts [Dict_getdef $arginfo -typesynopsis ""] + if {$ts ne ""} { #set arg_display [dict get $arginfo -typesynopsis] - set clause [dict get $arginfo -typesynopsis] + set clause $ts } else { #set arg_display $argname set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) - foreach tp_member [split $tp |] { - if {$tp_member eq "literal"} { + foreach tp_alternative [split $tp |] { + if {$tp_alternative eq "literal"} { lappend alternates [lindex $argname end] - } elseif {[string match literal(*) $tp_member]} { - set match [string range $tp_member 8 end-1] + } elseif {[string match literal(*) $tp_alternative]} { + set match [string range $tp_alternative 8 end-1] lappend alternates $match - } elseif {[string match literalprefix(*) $tp_member]} { - set match [string range $tp_member 14 end-1] + } elseif {[string match literalprefix(*) $tp_alternative]} { + set match [string range $tp_alternative 14 end-1] lappend alternates $match } else { lappend alternates $I$argname$NI @@ -7475,8 +8505,9 @@ tcl::namespace::eval punk::args { set n [expr {[llength $typelist]-1}] set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types set clause "" - if {[dict exists $arginfo -typesynopsis]} { - set tp_displaylist [dict get $arginfo -typesynopsis] + set ts [Dict_getdef $arginfo -typesynopsis ""] + if {$ts ne ""} { + set tp_displaylist $ts } else { set tp_displaylist [lrepeat [llength $typelist] ""] } @@ -7492,14 +8523,14 @@ tcl::namespace::eval punk::args { } #handle alternate-types e.g literal(text)|literal(binary) set alternates [list] - foreach tp_member [split $tp |] { - if {$tp_member eq "literal"} { + foreach tp_alternative [split $tp |] { + if {$tp_alternative eq "literal"} { lappend alternates $elementname - } elseif {[string match literal(*) $tp_member]} { - set match [string range $tp_member 8 end-1] + } elseif {[string match literal(*) $tp_alternative]} { + set match [string range $tp_alternative 8 end-1] lappend alternates $match - } elseif {[string match literalprefix(*) $tp_member]} { - set match [string range $tp_member 14 end-1] + } elseif {[string match literalprefix(*) $tp_alternative]} { + set match [string range $tp_alternative 14 end-1] lappend alternates $match } else { if {$td eq ""} { diff --git a/src/modules/punk/args/tclcore-999999.0a1.0.tm b/src/modules/punk/args/tclcore-999999.0a1.0.tm index 5c4ce089..6ca30aab 100644 --- a/src/modules/punk/args/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/tclcore-999999.0a1.0.tm @@ -52,6 +52,7 @@ package require textblock #*** !doctools #[item] [package {Tcl 8.6}] #[item] [package {punk::args}] +#[item] [package {textblock}] #*** !doctools #[list_end] @@ -61,38 +62,6 @@ package require textblock #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::args::tclcore::class { - #*** !doctools - #[subsection {Namespace punk::args::tclcore::class}] - #[para] class definitions - #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace @@ -365,6 +334,8 @@ tcl::namespace::eval punk::args::tclcore { fileName #todo punk::args::synopsis - show prefix highlighting mode -type literalprefix(text)|literalprefix(binary) -optional 1 + #test + #mode -type {{literalprefix text | literalprefix binary}} } "@doc -name Manpage: -url [manpage_tcl library]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @@ -1345,6 +1316,36 @@ tcl::namespace::eval punk::args::tclcore { body -type script -typesynopsis ${$I}body