diff --git a/src/bootsupport/modules/fauxlink-0.1.0.tm b/src/bootsupport/modules/fauxlink-0.1.0.tm index a94a5b9c..fe16b71a 100644 --- a/src/bootsupport/modules/fauxlink-0.1.0.tm +++ b/src/bootsupport/modules/fauxlink-0.1.0.tm @@ -34,7 +34,7 @@ #[para] The + symbol substitutes for forward-slashes. #[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) #[para] We deliberately treat higher % sequences literally. -#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [heart]) can remain literal for linking to urls. +#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls. #[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 #[para] e.g a link to a file file#A.txt in parent dir could be: #[para] file%23A.txt#..+file%23A.txt.fxlnk diff --git a/src/bootsupport/modules/fauxlink-0.1.1.tm b/src/bootsupport/modules/fauxlink-0.1.1.tm index 7aff6ec0..5d63ffef 100644 --- a/src/bootsupport/modules/fauxlink-0.1.1.tm +++ b/src/bootsupport/modules/fauxlink-0.1.1.tm @@ -34,7 +34,7 @@ #[para] The + symbol substitutes for forward-slashes. #[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) #[para] We deliberately treat higher % sequences literally. -#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [heart]) can remain literal for linking to urls. +#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls. #[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 #[para] e.g a link to a file file#A.txt in parent dir could be: #[para] file%23A.txt#..+file%23A.txt.fxlnk @@ -46,7 +46,7 @@ #[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined #[para] Extensions to behaviour should be added in the file as text data in Toml format, #[para] with custom data being under a single application-chosen table name -#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system. +#[para] The toplevel Toml table [lb]fauxlink[rb] is reserved for core extensions to this system. #[para] Aside from the 2 used for delimiting (+ #) #[para] certain characters which might normally be allowed in filesystems are required to be encoded #[para] e.g space and tab are required to be %20 %09 diff --git a/src/bootsupport/modules/overtype-1.6.5.tm b/src/bootsupport/modules/overtype-1.6.5.tm index 3c200d26..e78727d0 100644 --- a/src/bootsupport/modules/overtype-1.6.5.tm +++ b/src/bootsupport/modules/overtype-1.6.5.tm @@ -1366,7 +1366,8 @@ tcl::namespace::eval overtype { if {$overflowlength > 0} { #overlay line wider or equal - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + #review - we still expand_right for centred for now.. possibly should expand_both with ellipsis each end? + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] set rendered [tcl::dict::get $rinfo result] set overflow_right [tcl::dict::get $rinfo overflow_right] set unapplied [tcl::dict::get $rinfo unapplied] @@ -1547,7 +1548,7 @@ tcl::namespace::eval overtype { } else { #padded overtext #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset + #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] lappend outputlines [tcl::dict::get $rinfo result] } diff --git a/src/bootsupport/modules/punk-0.1.tm b/src/bootsupport/modules/punk-0.1.tm index 4bd8aae0..59efcc9c 100644 --- a/src/bootsupport/modules/punk-0.1.tm +++ b/src/bootsupport/modules/punk-0.1.tm @@ -7326,21 +7326,28 @@ namespace eval punk { if {$topic in [list tcl]} { - if {[punk::lib::system::has_tclbug_script_var]} { - append warningblock \n "minor warning: punk::lib::system::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" + if {[punk::lib::check::has_tclbug_script_var]} { + append warningblock \n "minor warning: punk::lib::check::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" } - if {[punk::lib::system::has_tclbug_safeinterp_compile]} { + if {[punk::lib::check::has_tclbug_safeinterp_compile]} { set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_safeinterp returned true!" \n + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_safeinterp returned true!" \n append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n - append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/1095bf7f75" + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/1095bf7f75]" append warningblock [a] } - if {[punk::lib::system::has_tclbug_list_quoting_emptyjoin]} { + if {[punk::lib::check::has_tclbug_lsearch_strideallinline]} { set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_list_quoting returned true!" \n + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_lsearch_strideallinline returned true!" \n + append warningblock "${indent}(lsearch using -stride -all -inline -subindices does not return values corresponding to subindex when a single -index value is used)" \n + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/5a1aaa201d]" + append warningblock [a] + } + if {[punk::lib::check::has_tclbug_list_quoting_emptyjoin]} { + set indent " " + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_list_quoting returned true!" \n append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n - append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/e38dce74e2" + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/e38dce74e2]" } } diff --git a/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 83c02d0b..22b3d5bf 100644 --- a/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,12 +18,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::aliascore 0 0.1.0] +#[manpage_begin punkshell_module_punk::aliascore 0 0.1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[titledesc {punkshell command aliases}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::aliascore] -#[keywords module] +#[keywords module alias] #[description] #[para] - diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index 1a40c952..ba5bcf90 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -417,8 +417,11 @@ tcl::namespace::eval punk::ansi { convert*\ clear*\ cursor_*\ + delete*\ detect*\ + erase*\ get_*\ + hyperlink\ move*\ reset*\ ansistrip*\ @@ -618,7 +621,7 @@ tcl::namespace::eval punk::ansi { set subtitle [tcl::dict::get $picinfo status] } set title [tcl::dict::get $picinfo filename] - set fr [textblock::frame -width $colwidth -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] + set fr [textblock::frame -checkargs 0 -width $colwidth -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] # -- --- --- --- #we need the max height of a row element to use join_basic instead of join below # -- --- --- --- @@ -3096,6 +3099,18 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return "\033\[?25l" } + # REVIEW - osc8 replays etc for split lines? - textblock + #the 'id' parameter logically connects split hyperlinks + proc hyperlink {uri {display ""}} { + if {$display eq ""} { + set display $uri + } + set params "" ;#todo e.g id=xyz123:foo=bar:baz=quux + set open "\x1b\]8\;$params\;$uri\x1b\\" + set close "\x1b\]8\;\;\x1b\\" + return ${open}${display}${close} + } + # -- --- --- --- --- proc move {row col} { #*** !doctools @@ -3634,11 +3649,27 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } set parts [punk::ansi::ta::split_codes $text] set out "" + #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" + # - (if/when lsearch -stride bug fixed) foreach {pt code} $parts { append out $pt } return $out } + proc ansistrip2 {text} { + #*** !doctools + #[call [fun ansistrip] [arg text] ] + #[para]Return a string with ansi codes stripped out + #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) + + if {[punk::ansi::ta::detect_g0 $text]} { + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + } + set parts [punk::ansi::ta::split_codes $text] + #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" + # - (if/when lsearch -stride bug fixed) + join [lmap v [lseq 0 to [llength $parts] by 2] {lindex $parts $v}] "" ;#slightly slower than above foreach + } #interp alias {} stripansi {} ::punk::ansi::ansistrip proc ansistripraw {text} { #*** !doctools @@ -3842,8 +3873,9 @@ tcl::namespace::eval punk::ansi { proc sgr_merge {codelist args} { set allparts [list] foreach c $codelist { - set cparts [punk::ansi::ta::split_codes_single $c] - lappend allparts {*}[lsearch -all -inline -not $cparts ""] + #set cparts [punk::ansi::ta::split_codes_single $c] + #lappend allparts {*}[lsearch -all -inline -not $cparts ""] + lappend allparts {*}[punk::ansi::ta::get_codes_single $c] } sgr_merge_singles $allparts {*}$args } @@ -4362,10 +4394,12 @@ tcl::namespace::eval punk::ansi::ta { # -- --- --- --- variable re_ansi_detect1 "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" # -- --- --- --- - #handrafted TRIE version of above. Somewhat difficult to construct and maintain. TODO - find a regext TRIE generator that works with Tcl regexes + #handrafted TRIE version of above. Somewhat difficult to construct and maintain. TODO - find a regexp TRIE generator that works with Tcl regexes #This does make things quicker - but it's too early to finalise the detect/split regexes (e.g missing \U0090 ) - will need to be redone. - variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} + #variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} + variable re_ansi_detect {(?:\x1b(?:\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\((?:0|B)|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} # -- --- --- --- + #variable re_csi_code {(?:\x1b\[|\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]} @@ -4389,9 +4423,7 @@ tcl::namespace::eval punk::ansi::ta { #can be used on dicts - but will check keys too. keys could also contain ansi and have escapes proc detect_in_list {list} { - detect [join $list " "] - } - proc detect_in_list2 {list} { + #loop is commonly faster than using join. (certain ansi codes triggering list quoting? review) foreach item $list { if {[detect $item]} { return 1 @@ -4399,6 +4431,11 @@ tcl::namespace::eval punk::ansi::ta { } return 0 } + #surprisingly - the ::join operation can be (relatively) slow on lists containing ansi + proc detect_in_list2 {list} { + detect [join $list " "] + } + proc detect_g0 {text} [string map [list [list $re_g0_group]] { regexp $text }] @@ -4580,13 +4617,108 @@ tcl::namespace::eval punk::ansi::ta { #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds) #- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped. - proc split_codes_single {text} { + proc split_codes_single2 {text} { variable re_ansi_split return [_perlish_split $re_ansi_split $text] } + proc split_codes_single3 {text} { + #copy from re_ansi_split + _perlish_split {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} $text + } + proc split_codes_single4 {text} { + if {$text eq ""} { + return {} + } + variable re_ansi_split + set re $re_ansi_split + #variable re_ansi_detect1 + #set re $re_ansi_detect1 + set list [list] + set start 0 + + #set re {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + #while {[regexp -start $start -indices -- {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} $text match]} {} + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + lappend list [tcl::string::range $text $start $matchStart-1] + if {$matchEnd < $matchStart} { + set e $matchStart + incr start + } else { + set e $matchEnd + set start [expr {$matchEnd+1}] + } + lappend list [tcl::string::range $text $matchStart $e] + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + proc split_codes_single {text} { + if {$text eq ""} { + return {} + } + variable re_ansi_split + set next 0 + set b -1 + set list [list] + set coderanges [regexp -indices -all -inline -- $re_ansi_split $text] + foreach cr $coderanges { + lappend list [tcl::string::range $text $next [lindex $cr 0]-1] [tcl::string::range $text [lindex $cr 0] [lindex $cr 1]] + set next [expr {[lindex $cr 1]+1}] + } + lappend list [tcl::string::range $text $next end] + return $list + } + proc get_codes_single {text} { + variable re_ansi_split + regexp -all -inline -- $re_ansi_split $text + } #review - tcl greedy expressions may match multiple in one element proc _perlish_split {re text} { + if {$text eq ""} { + return {} + } + set next 0 + set b -1 + set list [list] + set coderanges [regexp -indices -all -inline -- $re $text] + foreach cr $coderanges { + lappend list [tcl::string::range $text $next [lindex $cr 0]-1] [tcl::string::range $text [lindex $cr 0] [lindex $cr 1]] + set next [expr {[lindex $cr 1]+1}] + } + lappend list [tcl::string::range $text $next end] + return $list + } + proc _perlish_split2 {re text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchStart] + incr start + } else { + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + set start [expr {$matchEnd+1}] + } + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + proc _perlish_split3 {re text} { if {$text eq ""} { return {} } diff --git a/src/bootsupport/modules/punk/args-0.1.0.tm b/src/bootsupport/modules/punk/args-0.1.0.tm index bd4f70fe..4100b104 100644 --- a/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/bootsupport/modules/punk/args-0.1.0.tm @@ -256,10 +256,10 @@ tcl::namespace::eval punk::args::class { tcl::namespace::eval punk::args { tcl::namespace::export {[a-z]*} variable argspec_cache - variable argspecs + variable argspec_ids variable id_counter - set argspec_cache [tcl::dict::create] - set argspecs [tcl::dict::create] + set argspec_cache [tcl::dict::create] + set argspec_ids [tcl::dict::create] set id_counter 0 #*** !doctools @@ -296,12 +296,15 @@ tcl::namespace::eval punk::args { return $result } - #todo? -synonym ? (applies to opts only not values) - #e.g -background -synonym -bg -default White + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix e.g -corner -aliases {-corners} + #We mightn't want the prefix to be longer just because of an alias proc Get_argspecs {optionspecs args} { variable argspec_cache - variable argspecs + #variable argspecs ;#REVIEW!! + variable argspec_ids variable initial_optspec_defaults variable initial_valspec_defaults #ideally we would use a fast hash algorithm to produce a short key with low collision probability. @@ -319,31 +322,37 @@ tcl::namespace::eval punk::args { -type string\ -optional 1\ -allow_ansi 1\ - -validate_without_ansi 0\ + -validate_ansistripped 0\ -strip_ansi 0\ -nocase 0\ -choiceprefix 1\ + -choicerestricted 1\ -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ ] set valspec_defaults [tcl::dict::create\ -type string\ -optional 0\ -allow_ansi 1\ - -validate_without_ansi 0\ + -validate_ansistripped 0\ -strip_ansi 0\ -nocase 0\ -choiceprefix 1\ + -choicerestricted 1\ -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ ] - #we need a -choiceprefix default even though it often doesn't apply so we can look it up to display in Help if there are -choices + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices #default to 1 for convenience #checks with no default #-minlen -maxlen -range - #default -allow_ansi to 1 and -validate_without_ansi to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_without_ansi 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist set opt_required [list] set val_required [list] set arg_info [tcl::dict::create] @@ -465,7 +474,7 @@ tcl::namespace::eval punk::args { -anyopts { set opt_any $v } - -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix { + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted { #review - only apply to certain types? tcl::dict::set optspec_defaults $k $v } @@ -488,30 +497,31 @@ tcl::namespace::eval punk::args { dict - dictionary { set v dict } - none - any - ansistring { - - } - list { + none - "" - - - any - ansistring - globstring - list { } default { #todo - disallow unknown types unless prefixed with custom- } } - tcl::dict::set optspec_defaults $k $v + tcl::dict::set optspec_defaults -type $v } -optional - -allow_ansi - - -validate_without_ansi - + -validate_ansistripped - -strip_ansi - + -regexprepass - + -regexprefail - + -validationtransform - -multiple { #allow overriding of defaults for options that occur later tcl::dict::set optspec_defaults $k $v } default { - set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\ + set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -validationtransform\ } error "punk::args::Get_argspecs - unrecognised key '$k' in *opts line. Known keys: $known" } @@ -523,13 +533,19 @@ tcl::namespace::eval punk::args { switch -- $k { -min - -minvalues { + if {$v < 0} { + error "punk::args::Get_argspecs - minimum acceptable value for key '$k' in *opts line is 0. got $v" + } set val_min $v } -max - -maxvalues { + if {$v < -1} { + error "punk::args::Get_argspecs - minimum acceptable value for key '$k' in *opts line is -1 (indicating unlimited). got $v" + } set val_max $v } - -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -nocase { + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set valspec_defaults $k $v } @@ -563,16 +579,20 @@ tcl::namespace::eval punk::args { } -optional - -allow_ansi - - -validate_without_ansi - + -validate_ansistripped - -strip_ansi - + -regexprepass - + -regexprefail - + -validationtransform - -multiple { tcl::dict::set valspec_defaults $k $v } default { set known { -min -minvalues -max -maxvalues\ - -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\ + -minlen -maxlen -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -validationtransform\ } error "punk::args::Get_argspecs - unrecognised key '$k' in *values line. Known keys: $known" } @@ -637,30 +657,59 @@ tcl::namespace::eval punk::args { error "punk::args::get_dict - invalid -type 'none' for positional argument positional argument '$argname'" } } - any - ansistring { + any - anything { tcl::dict::set spec_merged -type any } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } 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] } } } - -default - -solo - -range - -choices - -choiceprefix - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { + -default - -solo - -range - -choices - -choiceprefix - -choicerestricted - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail + { #review -solo 1 vs -type none ? tcl::dict::set spec_merged $spec $specval } + -validationtransform { + #string is dict only 8.7/9+ + if {([llength $specval] % 2) != 0} { + error "punk::args::get_dict - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minlen - -maxlen - -range { + } + default { + set known_transform_keys [list -function -type -minlen -maxlen -range] ;#-choices etc? + error "punk::args::get_dict - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys" + } + } + } + + } default { - set known_argspecs [list -default -type -range -choices -choiceprefix -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help] + set known_argspecs [list -default -type -range -choices -choiceprefix -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -validationtransform\ + ] error "punk::args::get_dict - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" } } } set argspecs $spec_merged if {$is_opt} { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen + set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen } else { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen + set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen } tcl::dict::set arg_info $argname $argspecs tcl::dict::set arg_checks $argname $argchecks @@ -693,8 +742,8 @@ tcl::namespace::eval punk::args { } - set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen - set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen + set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen + set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen set result [tcl::dict::create\ id $spec_id\ @@ -717,30 +766,55 @@ tcl::namespace::eval punk::args { proc_info $proc_info\ ] tcl::dict::set argspec_cache $cache_key $result - tcl::dict::set argspecs $spec_id $optionspecs + #tcl::dict::set argspecs $spec_id $optionspecs + tcl::dict::set argspec_ids $spec_id $optionspecs #puts "xxx:$result" return $result } proc get_spec {id} { - variable argspecs - if {[tcl::dict::exists $argspecs $id]} { - return [tcl::dict::get $argspecs $id] + variable argspec_ids + if {[tcl::dict::exists $argspec_ids $id]} { + return [tcl::dict::get $argspec_ids $id] } return } proc get_spec_ids {{match *}} { - variable argspecs - return [tcl::dict::keys $argspecs $match] + variable argspec_ids + return [tcl::dict::keys $argspec_ids $match] } #for use within get_dict only #This mechanism gets less-than-useful results for oo methods #e.g {$obj} proc Get_caller {} { - set cmdinfo [tcl::dict::get [tcl::info::frame -3] cmd] + set call_level -3 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] #puts "-->$cmdinfo" #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } set caller [regexp -inline {\S+} $cmdinfo] if {$caller eq "namespace"} { set cmdinfo "punk::args::get_dict called from namespace" @@ -748,7 +822,18 @@ tcl::namespace::eval punk::args { return $cmdinfo } + #basic recursion blocker + variable arg_error_isrunning 0 proc arg_error {msg spec_dict {badarg ""}} { + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $badarg" + } + set arg_error_isrunning 1 + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + # use basic colours here to support terminals without extended colours #todo - add checks column (e.g -minlen -maxlen) set errmsg $msg @@ -802,136 +887,120 @@ tcl::namespace::eval punk::args { #set greencheck [a+ web-limegreen]\u2713[a] set greencheck [a+ brightgreen]\u2713[a] - if {![catch {package require punk::trie}]} { - set opt_names_display [list] - set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - set M "\x1b\[32m" ;#mark in green - set RST "\x1b\[m" - foreach c [dict get $spec_dict opt_names] { - set id [dict get $idents $c] - if {$id eq $c} { - lappend opt_names_display $M$c$RST - } else { - set idlen [string length $id] - lappend opt_names_display "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" - } - } - } else { - set opt_names_display [dict get $spec_dict opt_names] - } - - - foreach argshow $opt_names_display arg [dict get $spec_dict opt_names] { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - #set default $c_default[dict get $arginfo -default] - set default [dict get $arginfo -default] - } else { - set default "" - } - set help [::punk::args::Dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - } else { - set casemsg " (case sensitive)" - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - append help "Choices$prefixmsg$casemsg" - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - append help "\n " [join [dict get $arginfo -choices] "\n "] - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - set M "\x1b\[32m" ;#mark in green - set RST "\x1b\[m" - foreach c [dict get $arginfo -choices] { - set id [dict get $idents $c] - if {$id eq $c} { - append help "\n " "$M$c$RST" - } else { - set idlen [string length $id] - append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" - } - } - } errM]} { - puts stderr "prefix marking failed\n$errM" - append help "\n " [join [dict get $arginfo -choices] "\n "] + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict opt_names]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $spec_dict opt_names] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] } - } - } - if {[::punk::args::Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck + lappend opt_names_display $M$prefix$RST$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } } else { - set multiple "" - } - $t add_row [list $argshow [dict get $arginfo -type] $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg + set opt_names [dict get $spec_dict opt_names] + set opt_names_display $opt_names } } - foreach arg [dict get $spec_dict val_names] { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - set default [dict get $arginfo -default] - } else { - set default "" - } - set help [::punk::args::Dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" + set val_names [dict get $spec_dict val_names] + set val_names_display $val_names + + #display options first then values + foreach argumentset [list [list $opt_names_display $opt_names] [list $val_names_display $val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict arg_info $arg] + if {[dict exists $arginfo -default]} { + #set default $c_default[dict get $arginfo -default] + set default [dict get $arginfo -default] } else { - set casemsg " (case sensitive)" + set default "" } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" + set help [::punk::args::Dict_getdef $arginfo -help ""] + if {[dict exists $arginfo -choices]} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + } else { + set casemsg " (case sensitive)" + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set formattedchoices [list] + append help " Choices$prefixmsg$casemsg" + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + set formattedchoices [dict get $arginfo -choices] + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $arginfo -choices] { + set id [dict get $idents $c] + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend formattedchoices "$M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail]" + } + } errM]} { + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + set formattedchoices [dict get $arginfo -choices] + + } + } + set numcols 4 + if {[llength $formattedchoices] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formattedchoices] + } + #risk of recursing + set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices] + append help \n[textblock::join -- " " $choicetable] + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } } - append help "Choices$prefixmsg$casemsg" - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[::punk::args::Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck } else { - if {[catch { - set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - set M "\x1b\[32m" ;#mark in green - set RST "\x1b\[m" - foreach c [dict get $arginfo -choices] { - set id [dict get $idents $c] - if {$id eq $c} { - append help "\n " "$M$c$RST" - } else { - set idlen [string length $id] - append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" - } - } - } errM]} { - puts stderr "prefix marking failed\n$errM" - append help "\n " [join [dict get $arginfo -choices] "\n "] - } + set multiple "" + } + $t add_row [list $argshow [dict get $arginfo -type] $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg } - } - if {[punk::args::Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } - $t add_row [list $arg [dict get $arginfo -type] $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg } } @@ -950,8 +1019,10 @@ tcl::namespace::eval punk::args { } } else { - #todo - something boring + #couldn't load textblock package + #just return the original errmsg without formatting } + set arg_error_isrunning 0 #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. #Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg @@ -962,6 +1033,14 @@ tcl::namespace::eval punk::args { #provide ability to look up and reuse definitions from ids etc # + proc get_dict_by_id {id {arglist ""}} { + set spec [get_spec $id] + if {$spec eq ""} { + error "punk::args::get_dict_by_id - no such id: $id" + } + return [get_dict $spec $arglist] + } + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. #only supports -flag val pairs, not solo options @@ -1054,6 +1133,171 @@ tcl::namespace::eval punk::args { #todo: -minmultiple -maxmultiple ? set opts $opt_defaults + + if {$id ne "jtest"} { + set arglist {} + set values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "arg_info: $arg_info" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + break + } + + if {[tcl::string::match -* $a]} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set values [lrange $rawargs $i+1 end] + } + } else { + #unlimited number of values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set values [lrange $rawargs $i+1 end] + } + break + } else { + set fullopt [tcl::prefix match -error "" $opt_names $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + break + } + + set flagval [lindex $rawargs $i+1] + if {[dict get $arg_info $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + #review - what if user sets first value that happens to match a default? + if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { + #first occurrence of this flag, whilst stored value matches default + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + incr vals_remaining_possible -2 + if {[incr i] > $maxidx} { + arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs $fullopt + } + } else { + #solo + if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $opts $fullopt] == 0} { + #review - what if default at time opt was specified is not zero? we will end up with more items in the list than the number of times the flag was specified + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + incr vals_remaining_possible -1 + } + lappend flagsreceived $fullopt ;#dups ok + } else { + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option + tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $opt_checks_defaults + if {[tcl::dict::get $arg_info $a -type] ne "none"} { + if {[tcl::dict::get $arg_info $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + lappend flagsreceived $a ;#adhoc flag as supplied + if {[incr i] > $maxidx} { + arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $arg_info $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + } + } else { + #set errmsg [tcl::string::map [list %caller% [Get_caller]] $fullopt] + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" + arg_error $errmsg $argspecs $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + break + } + } + } else { + set values $rawargs ;#no -flags detected + set arglist [list] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + } + + + if {$id eq "jtest"} { if {[set eopts [lsearch -exact $rawargs "--"]] >= 0} { lappend flagsreceived -- set values [lrange $rawargs $eopts+1 end] @@ -1233,6 +1477,10 @@ tcl::namespace::eval punk::args { set arglist [list] } } + } + + + set validx 0 set in_multiple "" set valnames_received [list] @@ -1328,7 +1576,7 @@ tcl::namespace::eval punk::args { set thisarg_checks [tcl::dict::get $arg_checks $argname] set is_multiple [tcl::dict::get $thisarg -multiple] set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_without_ansi [tcl::dict::get $thisarg -validate_without_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] set has_default [tcl::dict::exists $thisarg -default] if {$has_default} { @@ -1336,53 +1584,150 @@ tcl::namespace::eval punk::args { } set type [tcl::dict::get $thisarg -type] set has_choices [tcl::dict::exists $thisarg -choices] + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [punk::args::Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + set validationtransform [tcl::dict::get $thisarg -validationtransform] + if {$is_multiple} { set vlist $v } else { set vlist [list $v] } - if {!$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" - } - } - } - if {$is_validate_without_ansi} { - #validate_without_ansi 1 + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 package require punk::ansi set vlist_check [list] foreach e $vlist { lappend vlist_check [punk::ansi::ansistrip $e] } } else { - #validate_without_ansi 0 + #validate_ansistripped 0 set vlist_check $vlist } - set is_default 0 - if {$has_default} { - foreach e_check $vlist_check { - if {$e_check eq $defaultval} { - incr is_default + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + if {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choices [tcl::dict::get $thisarg -choices] + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + set nocase [tcl::dict::get $thisarg -nocase] + if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { + set dname opts + } else { + set dname values_dict + } + set idx 0 ;# + #opts/values_dict $argname membmer 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 { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $choices] + set v_test [tcl::string::tolower $e_check] + } else { + set casemsg " (case sensitive)" + set v_test $e_check + set choices_test $choices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $e eq $defaultval}] + if {!$matches_default} { + if {$choiceprefix} { + set chosen [tcl::prefix::match -error "" $choices_test $v_test] + if {$chosen ne ""} { + set choice_in_list 1 + #can we handle empty string as a choice? It should just work - REVIEW/test + #must use exact in case glob chars present e.g * ? [] (also ansi has square brackets) + set choice [lsearch -exact -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $choice + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $choice + } + } + } else { + set choice_in_list [expr {$v_test in $choices_test}] + } } + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $v_test + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $v_test + } + lappend vlist_validate $e + lappend vlist_check_validate $e_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs $argname + } + } + incr idx } - if {$is_default eq [llength $vlist]} { - set is_default 1 - } else { - #important to set 0 here too e.g if only one element of many matches default - set is_default 0 + #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 + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + if {$e_check ne $defaultval} { + lappend vlist_validate $e + lappend vlist_check_validate $e + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + } } } #puts "argname:$argname v:$v is_default:$is_default" #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. #arguments that are at their default are not subject to type and other checks - if {$is_default == 0} { + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { switch -- $type { any {} list { @@ -1411,9 +1756,66 @@ tcl::namespace::eval punk::args { } } } - string { + 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 e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punk::lib::ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punk::lib::ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + arg_error "Option $argname for [Get_caller] didn't pass regexprefail regex: '$regexprefail' got '$e'" $argspecs $argname + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minlen 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 -minlen 0 -maxlen 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs $argname + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs $argname + } + } + } + } + if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $vlist_check { + foreach e_check $remaining_e_check { #safe jumptable test #dict for {checkopt checkval} $thisarg_checks {} tcl::dict::for {checkopt checkval} $thisarg_checks { @@ -1436,28 +1838,40 @@ tcl::namespace::eval punk::args { } } } - ansistring { - package require ansi - } int { #-range 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 if {[tcl::dict::exists $thisarg -range]} { lassign [tcl::dict::get $thisarg -range] low high - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname - } + if {"$low$high" ne ""} { if {$low eq ""} { - if {$e_check < $low} { - arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs $argname + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname + } + #lowside unspecified - check only high + if {$e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs $argname + } } } elseif {$high eq ""} { - if {$e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs $argname + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname + } + #highside unspecified - check only low + if {$e_check < $low} { + arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs $argname + } } } else { - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs $argname + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs $argname + } } } } @@ -1577,49 +1991,14 @@ tcl::namespace::eval punk::args { } } } - if {$has_choices} { - #todo -choicelabels - set choices [tcl::dict::get $thisarg -choices] - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set nocase [tcl::dict::get $thisarg -nocase] - foreach e $vlist e_check $vlist_check { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $choices] - set v_test [tcl::string::tolower $e_check] - } else { - set casemsg " (case sensitive)" - set v_test $e_check - set choices_test $choices - } - set choice_ok 0 - if {$choiceprefix} { - if {![catch {tcl::prefix::match $choices_test $v_test} chosen]} { - set choice_ok 1 - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice [lsearch -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list - if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { - tcl::dict::set opts $argname $choice - } else { - tcl::dict::set values_dict $argname $choice - } - } - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - set choice_ok [expr {$v_test in $choices_test}] - } - if {!$choice_ok} { - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs $argname - } - } - } + } + if {$is_strip_ansi} { - set stripped_list [lmap e $vlist {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach if {[tcl::dict::get $thisarg -multiple]} { if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { - tcl::dict::set opts $argname $stripped_list + tcl::dict::set opts $argname $stripped_list } else { tcl::dict::set values_dict $argname $stripped_list } diff --git a/src/bootsupport/modules/punk/assertion-0.1.0.tm b/src/bootsupport/modules/punk/assertion-0.1.0.tm index bee5a415..8ad0af62 100644 --- a/src/bootsupport/modules/punk/assertion-0.1.0.tm +++ b/src/bootsupport/modules/punk/assertion-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::assertion 0 0.1.0] +#[manpage_begin punkshell_module_punk::assertion 0 0.1.0] #[copyright "2024"] #[titledesc {assertion alternative to control::assert}] [comment {-- Name section and table of contents description --}] #[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index 001a7653..e3c188af 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -593,7 +593,13 @@ namespace eval punk::console { if {!$::punk::console::ansi_available} { return "" } - set callid [info cmdcount] ;#info cmdcount is almost as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context + # -- --- + #set callid [info cmdcount] ;#info cmdcount is fast, though not as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context + #clock clicks is approx 2x faster - but can sometimes give duplicates if called sequentially e.g list [clock clicks] [clock clicks] + #Either is suitable here, where subsequent calls will be relatively far apart in time + #speed of call insignificant compared to function + set callid [clock clicks] + # -- --- # upvar ::punk::console::ansi_response_chunk accumulator diff --git a/src/bootsupport/modules/punk/docgen-0.1.0.tm b/src/bootsupport/modules/punk/docgen-0.1.0.tm index f4d26342..cea2d287 100644 --- a/src/bootsupport/modules/punk/docgen-0.1.0.tm +++ b/src/bootsupport/modules/punk/docgen-0.1.0.tm @@ -31,6 +31,7 @@ namespace eval punk::docgen { error "get_doctools_comments file '$fname' not found" } set fd [open $fname r] + chan conf $fd -translation binary set data [read $fd] close $fd if {![string match "*#\**!doctools*" $data]} { diff --git a/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/bootsupport/modules/punk/lib-0.1.1.tm index 070621bc..da6de45d 100644 --- a/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -129,7 +129,7 @@ tcl::namespace::eval punk::lib::ensemble { list [tcl::namespace::which namespace] export *] while 1 { - set renamed ${routinens}::${routinetail}_[info cmdcount] + set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] if {[tcl::namespace::which $renamed] eq {}} break } @@ -147,6 +147,89 @@ tcl::namespace::eval punk::lib::ensemble { } } +# some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated +tcl::namespace::eval punk::lib::check { + proc has_tclbug_script_var {} { + + set script {set j [list spud] ; list} + append script \n + uplevel #0 $script + set rep1 [tcl::unsupported::representation $::j] + set script "" + set rep2 [tcl::unsupported::representation $::j] + + set nostring1 [string match "*no string" $rep1] + set nostring2 [string match "*no string" $rep2] + + #we assume it should have no string rep in either case + #Review: check Tcl versions for behaviour/consistency + if {!$nostring2} { + return true + } else { + return false + } + } + proc has_tclbug_lsearch_strideallinline {} { + #bug only occurs with single -index value combined with -stride -all -inline -subindices + #https://core.tcl-lang.org/tcl/tktview/5a1aaa201d + set result [lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *] + return [expr {$result ne "a2"}] + } + + proc has_tclbug_list_quoting_emptyjoin {} { + #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 + set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases + set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" + return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. + } + + proc has_tclbug_safeinterp_compile {{show 0}} { + #ensemble calls within safe interp not compiled + namespace eval [namespace current]::testcompile { + proc ensembletest {} {string index a 0} + } + + set has_bug 0 + + set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] + if {$show} { + puts outer: + puts $bytecode_outer + } + if {![interp issafe]} { + #test of safe subinterp only needed if we aren't already in a safe interp + if {![catch { + interp create x -safe + } errMsg]} { + x eval {proc ensembletest {} {string index a 0}} + set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] + if {$show} { + puts safe: + puts $bytecode_safe + } + interp delete x + #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) + #It's possible the interp we're running in is also not compiling ensembles. + #we could then get a result of 2 - which still indicates a problem + if {[string last "invokeStk" $bytecode_safe] >= 1} { + incr has_bug + } + } else { + #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? + #unlikely - but we should warn + puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" + } + } + + namespace delete [namespace current]::testcompile + + if {[string last "invokeStk" $bytecode_outer] >= 1} { + incr has_bug + } + return $has_bug + } +} + tcl::namespace::eval punk::lib::compat { #*** !doctools #[subsection {Namespace punk::lib::compat}] @@ -185,7 +268,7 @@ tcl::namespace::eval punk::lib::compat { return [lmap v $keep {lindex $v 1}] } #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. - #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 - and even in 8.7 it doesn't seem to allow returning one index of the stridden 'group' + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 if {"::lpop" ne [info commands ::lpop]} { #puts stderr "Warning - no built-in lpop" @@ -651,6 +734,180 @@ namespace eval punk::lib { } } + proc lzip {args} { + switch -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [lzip2lists {*}$args]} + 3 {return [lzip3lists {*}$args]} + 4 {return [lzip4lists {*}$args]} + 5 {return [lzip5lists {*}$args]} + 6 {return [lzip6lists {*}$args]} + 7 {return [lzip7lists {*}$args]} + 8 {return [lzip8lists {*}$args]} + 9 {return [lzip9lists {*}$args]} + 10 {return [lzip10lists {*}$args]} + 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } + default { + if {[llength $args] < 4000} { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } else { + return [lzipn {*}$args] + } + } + } + } + + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + puts "proc punk::lib::lzip${n}lists {$arglist} \{" + puts "$body" + puts "\}" + proc ::punk::lib::lzip${n}lists $arglist $body + } + + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } + + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} + } + + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + + if {[join $cur {}] == {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 + } + return $zip_l + } + #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible + if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { + #-stride either not available - or has bug preventing use of main algorithm below + proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + } else { + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + } + #experiment with equiv of js template literals with ${expression} in templates #e.g tstr {This is the value of x in calling scope ${$x} !} #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} @@ -2696,7 +2953,8 @@ namespace eval punk::lib { lappend opts -block {} } set text [lindex $args end] - tailcall linelist {*}$opts $text + #tailcall linelist {*}$opts $text + return [linelist {*}$opts $text] } #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds proc lines_as_list2 {args} { @@ -2714,9 +2972,8 @@ namespace eval punk::lib { # important for pipeline & match_assign # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace - set linelist_body { - set usage "linelist ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" if {[llength $args] == 0} { error "linelist missing textchunk argument usage:$usage" } @@ -2917,7 +3174,7 @@ namespace eval punk::lib { set replaycodes $RST ;#todo - default? set transformed [list] #shortcircuit common case of no ansi - #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the have backslash escapes due to Tcl list quoting and escaping behaviour. + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) @@ -2940,17 +3197,20 @@ namespace eval punk::lib { foreach ln $linelist { #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable - set ansisplits [punk::ansi::ta::split_codes_single $ln] - if {[llength $ansisplits]<= 1} { + #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + #get_codes_single lists only the codes. no plaintext or empty elements + set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits] == 0} { #plaintext only - no ansi codes in line lappend transformed [string cat $replaycodes $ln $RST] #leave replaycodes as is for next line set nextreplay $replaycodes } else { set tail $RST - set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + set lastcode [lindex $ansisplits end] ;#may or may not be SGR + set lastcodeoffset [expr {[string length $lastcode]-1}] if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { - if {[lindex $ansisplits end] eq ""} { + if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { #last plaintext is empty. So the line is already suffixed with a reset set tail "" set nextreplay $RST @@ -2960,7 +3220,8 @@ namespace eval punk::lib { set tail $RST set nextreplay $RST } - } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #code is at tail (no trailing plaintext) #No tail reset - and no need to examine whole line to determine stack that is in effect set tail $RST set nextreplay $lastcode @@ -2971,7 +3232,7 @@ namespace eval punk::lib { set tail $RST #determine effective replay for line set codestack [list start] - foreach {pt code} $ansisplits { + foreach code $ansisplits { if {[punk::ansi::codetype::is_sgr_reset $code]} { set codestack [list] ;#different from 'start' marked - this means we've had a reset } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { @@ -3043,89 +3304,418 @@ namespace eval punk::lib { #by putting in calls to punk::ansi the user will get appropriate error messages set linelist_body [string map { "package require punk::ansi"} $linelist_body] } - proc linelist {args} $linelist_body - - - interp alias {} errortime {} punk::lib::errortime - proc errortime {script groupsize {iters 2}} { - #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance - set i 0 - set times {} - if {$iters < 2} {set iters 2} - - for {set i 0} {$i < $iters} {incr i} { - set result [uplevel [list time $script $groupsize]] - lappend times [lindex $result 0] - } - - set average 0.0 - set s2 0.0 - - foreach time $times { - set average [expr {$average + double($time)/$iters}] - } - foreach time $times { - set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + set linelist_body_original { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? - set sigma [expr {int(sqrt($s2))}] - set average [expr int($average)] - - return "$average +/- $sigma microseconds per iteration" - } - - #test function to use with show_jump_tables - #todo - check if switch compilation to jump tables differs by Tcl version - proc switch_char_test {c} { - set dec [scan $c %c] - foreach t [list 1 2 3] { - switch -- $c { - x { - return [list $dec x $t] + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v } - y { - return [list $dec y $t] + default { + error "linelist: Unrecognized option '$o' usage:$usage" } - z { - return [list $dec z $t] + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } } } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + } + - #tcl 8.6/8.7 (at least) - #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable - switch -- $c { - a { - return [list $dec a] - } - {"} { - return [list $dec dquote] + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 } - {[} {return [list $dec lb]} - {]} {return [list $dec rb]} - "{" { - return [list $dec lbrace] + trimleft { + set tl_left 1 } - "}" { - return [list $dec rbrace] + trimright { + set tl_right 1 } default { - return [list $dec $c] + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" } - } - - - - } - - #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) - proc show_jump_tables {args} { - #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. - if {[llength $args] == 1} { - set data [tcl::unsupported::disassemble proc [lindex $args 0]] - } elseif {[llength $args] == 2} { - #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits]<= 1} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[lindex $ansisplits end] eq ""} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach {pt code} $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + proc linelist {args} $linelist_body + + + interp alias {} errortime {} punk::lib::errortime + proc errortime {script groupsize {iters 2}} { + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance + set i 0 + set times {} + if {$iters < 2} {set iters 2} + + for {set i 0} {$i < $iters} {incr i} { + set result [uplevel [list time $script $groupsize]] + lappend times [lindex $result 0] + } + + set average 0.0 + set s2 0.0 + + foreach time $times { + set average [expr {$average + double($time)/$iters}] + } + + foreach time $times { + set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + } + + set sigma [expr {int(sqrt($s2))}] + set average [expr int($average)] + + return "$average +/- $sigma microseconds per iteration" + } + + #test function to use with show_jump_tables + #todo - check if switch compilation to jump tables differs by Tcl version + proc switch_char_test {c} { + set dec [scan $c %c] + foreach t [list 1 2 3] { + switch -- $c { + x { + return [list $dec x $t] + } + y { + return [list $dec y $t] + } + z { + return [list $dec z $t] + } + } + } + + #tcl 8.6/8.7 (at least) + #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable + switch -- $c { + a { + return [list $dec a] + } + {"} { + return [list $dec dquote] + } + {[} {return [list $dec lb]} + {]} {return [list $dec rb]} + "{" { + return [list $dec lbrace] + } + "}" { + return [list $dec rbrace] + } + default { + return [list $dec $c] + } + } + + + + } + + #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) + proc show_jump_tables {args} { + #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. + if {[llength $args] == 1} { + set data [tcl::unsupported::disassemble proc [lindex $args 0]] + } elseif {[llength $args] == 2} { + #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. #not sure if this handles more complex hierarchies or mixins etc. lassign $args obj method if {![info object isa object $obj]} { @@ -3316,7 +3906,87 @@ namespace eval punk::lib { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::lib::flatgrid { + namespace export filler_count rows cols col row block + #WARNING - requires lseq and 'lsearch -stride' + #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 + #todo - 8.6 fallback? + + proc filler_count {listlen numcolumns} { + #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error + #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense + expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} + } + proc rows {list numcolumns {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set rows [list] + set i 1 + foreach s [lrange $splits 0 end-1] { + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + incr i + } + return $rows + } + proc cols {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] + } + return $cols + } + proc cols2 {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [col2 $list $numcolumns $colindex $blank] + } + return $cols + } + proc col {list numcolumns colindex {blank NULL}} { + lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * + } + proc col2 {list numcolumns colindex {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set col [list] + foreach s [lrange $splits 0 end-1] { + lappend col [lindex $padded_list $s+$colindex] + } + return $col + } + proc col3 {list numcolumns colindex {blank NULL}} { + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} + } + proc col4 {list numcolumns colindex {blank NULL}} { + #slow + set vars [lrepeat $numcolumns _] + lset vars $colindex v + if {$blank eq ""} { + return [lmap $vars $list {set v}] + } + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} + } + + proc block {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } + proc block2 {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols2 $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } +} @@ -3330,78 +4000,6 @@ tcl::namespace::eval punk::lib::system { #[para] Internal functions that are not part of the API #[list_begin definitions] - proc has_tclbug_script_var {} { - set script {set j [list spud] ; list} - append script \n - uplevel #0 $script - set rep1 [tcl::unsupported::representation $::j] - set script "" - set rep2 [tcl::unsupported::representation $::j] - - set nostring1 [string match "*no string" $rep1] - set nostring2 [string match "*no string" $rep2] - - #we assume it should have no string rep in either case - #Review: check Tcl versions for behaviour/consistency - if {!$nostring2} { - return true - } else { - return false - } - } - - proc has_tclbug_list_quoting_emptyjoin {} { - #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 - set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases - set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" - return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. - } - - proc has_tclbug_safeinterp_compile {{show 0}} { - #ensemble calls within safe interp not compiled - namespace eval [namespace current]::testcompile { - proc ensembletest {} {string index a 0} - } - - set has_bug 0 - - set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] - if {$show} { - puts outer: - puts $bytecode_outer - } - if {![interp issafe]} { - #test of safe subinterp only needed if we aren't already in a safe interp - if {![catch { - interp create x -safe - } errMsg]} { - x eval {proc ensembletest {} {string index a 0}} - set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] - if {$show} { - puts safe: - puts $bytecode_safe - } - interp delete x - #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) - #It's possible the interp we're running in is also not compiling ensembles. - #we could then get a result of 2 - which still indicates a problem - if {[string last "invokeStk" $bytecode_safe] >= 1} { - incr has_bug - } - } else { - #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? - #unlikely - but we should warn - puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" - } - } - - namespace delete [namespace current]::testcompile - - if {[string last "invokeStk" $bytecode_outer] >= 1} { - incr has_bug - } - return $has_bug - } proc mostFactorsBelow {n} { ##*** !doctools diff --git a/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm index 1d8d40e1..8d68b28a 100644 --- a/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm @@ -48,6 +48,7 @@ namespace eval punk::mix::commandset::doc { set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man] foreach maybedoomed $oldfiles { set fd [open $maybedoomed r] + chan conf $fd -translation binary set data [read $fd] close $fd if {[string match "*--- punk::docgen overwrites *" $data]} { @@ -170,7 +171,7 @@ namespace eval punk::mix::commandset::doc { -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 *values -min 0 -max -1 - patterns -default {*} -type any -multiple 1 + patterns -default {*.man} -type any -multiple 1 } $args] set opt_individual [tcl::dict::get $argd opts -individual] set patterns [tcl::dict::get $argd values patterns] @@ -190,7 +191,7 @@ namespace eval punk::mix::commandset::doc { set docroot $projectdir/src/doc cd $docroot - if {!$opt_individual && "*" in $patterns} { + if {!$opt_individual && "*.man" in $patterns} { if {[catch { dtplite validate $docroot } errM]} { @@ -251,6 +252,7 @@ namespace eval punk::mix::commandset::doc { append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n foreach fullpath $matched_paths { + puts stdout "do_docgen processing: $fullpath" set doctools [punk::docgen::get_doctools_comments $fullpath] if {$doctools ne ""} { set fname [file tail $fullpath] diff --git a/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index c61db428..65a9fb77 100644 --- a/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -1,5 +1,5 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev make' or src/make.tcl to update from -buildversion.txt # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -13,19 +13,70 @@ # @@ Meta End +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_scriptwrap 0 0.1.0] +#[copyright "2024"] +#[titledesc {scriptwrap polyglot tool}] [comment {-- Name section and table of contents description --}] +#[moddesc {scriptwrap tool}] [comment {-- Description at end of page heading --}] +#[require punk::mix::commandset::scriptwrap] +#[keywords module commandset launcher scriptwrap] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of scriptwrap +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by poshinfo +#[list_begin itemized] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements ##e.g package require frobz +package require punk::lib +package require punk::args package require punk::mix package require punk::mix::base package require punk::fileline +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::lib}] +#[item] [package {punk::args}] +#[item] [package {punk::mix}] +#[item] [package {punk::base}] +#[item] [package {punk::fileline}] + +#*** !doctools +#[list_end] + +#*** !doctools +#[section API] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + namespace eval punk::mix::commandset::scriptwrap { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::scriptwrap}] + #[para] Core API functions for punk::mix::commandset::scriptwrap + #[list_begin definitions] + namespace export * namespace eval fileline { @@ -1192,22 +1243,33 @@ namespace eval punk::mix::commandset::scriptwrap { return $result } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap ---}] namespace eval lib { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] + #[para] Library API functions for punk::mix::commandset::scriptwrap + #[list_begin definitions] proc get_wrapper_folders {args} { set argd [punk::args::get_dict { #*** !doctools #[call [fun get_wrapper_folders] [arg args] ] - #[para] Return list of dicts representing wrapper folders. keys: basefolder sourceinfo + #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo #[para] Arguments: # [list_begin arguments] # [arg_def string args] name-value pairs -scriptpath # [list_end] - *proc -name get_wrapper_folders + *id punk::mix::commandset::scriptwrap + *proc -name punk::mix::commandset::get_wrapper_folders + *opts -anyopts 0 - -scriptpath -default "" + -scriptpath -default "" -type directory\ + -help "" + #todo -help folder within a punk.templates provided area??? + *values -minvalues 0 -maxvalues 0 } $args] @@ -1377,11 +1439,16 @@ namespace eval punk::mix::commandset::scriptwrap { return [dict create ok $status linecount [llength $lines] data $tags errors $errors] } - + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap::lib ---}] } namespace eval batchlib { - # + #*** !doctools + #[subsection {Namespace punk::mix::commandset::scriptwrap::batchlib}] + #[para] Utility funcions for processing windows .bat files + #[list_begin definitions] + #see also: https://www.dostips.com/forum/viewtopic.php?t=3803 'Rules for label names vs GOTO and CALL # review - we may need different get_callsite_label functions? @@ -1647,23 +1714,13 @@ namespace eval punk::mix::commandset::scriptwrap { #return rawlabel so we can see it as it appears in the data - as opposed to how it is interpreted as a label by cmd.exe return [list labelfound 1 label $label rawlabel $rawlabel] } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap::batchlib ---}] } } - - - - - - - - - - - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::commandset::scriptwrap { @@ -1671,3 +1728,6 @@ package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::com set version 0.1.0 }] return + +#*** !doctools +#[manpage_end] \ No newline at end of file diff --git a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 9cf44529..9bf5a060 100644 --- a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -20,10 +20,10 @@ #*** !doctools #[manpage_begin shellspy_module_punk::nav::fs 0 0.1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[titledesc {punk::nav::fs console filesystem navigation}] [comment {-- Name section and table of contents description --}] +#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] #[require punk::nav::fs] -#[keywords module] +#[keywords module filesystem terminal] #[description] #[para] - @@ -936,7 +936,7 @@ tcl::namespace::eval punk::nav::fs { #windows doesn't consider dotfiles as hidden - mac does (?) #we add dotfiles to flaggedhidden list in case there is some other mechanism that has flagged items as hidden if {$::tcl_platform(platform) ne "windows"} { - lappend flaggedhidden {*}[lsearch -all -inline [concat $dirs $files] ".*"] + lappend flaggedhidden {*}[lsearch -all -inline [list {*}$dirs {*}$files] ".*"] #e.g we can have dupes in the case where there are vfs mounted files that appear as dirs #as we will need to do a (nat)sort as a last step - it will be faster to not sort items prematurely #set flaggedhidden [lsort -unique $flaggedhidden] @@ -977,7 +977,8 @@ tcl::namespace::eval punk::nav::fs { # -- --- - foreach nm [concat $dirs $files] { + #jmn + foreach nm [list {*}$dirs {*}$files] { if {[punk::winpath::illegalname_test $nm]} { lappend nonportable $nm } @@ -1272,7 +1273,8 @@ tcl::namespace::eval punk::nav::fs { #set widest1 [punk::pipedata [list {*}$dirs ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] - set widest1 [tcl::mathfunc::max {*}[lmap v [concat $dirs [list ""]] {string length $v}]] + #set widest1 [tcl::mathfunc::max {*}[lmap v [concat $dirs [list ""]] {string length $v}]] + set widest1 [tcl::mathfunc::max {*}[lmap v [list {*}$dirs ""] {string length $v}]] set displaylist [list] set col1 [string repeat " " [expr {$widest1 + 2}]] diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm index 10250a9b..b9dc3707 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -755,7 +755,9 @@ tcl::namespace::eval punk::ns { set seencmds [list] set masked [list] ;# - set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] + #jmn + #set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] + set cmdsets [list {*}$procs {*}$ensembles {*}$ooclasses {*}$ooobjects {*}$ooprivateobjects {*}$ooprivateclasses {*}$native {*}$interps {*}$coroutines {*}$zlibstreams] foreach a $aliases { if {[list c $a] in $elements} { #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo @@ -1691,7 +1693,8 @@ tcl::namespace::eval punk::ns { proc _pkguse_vars {varnames} { while {"pkguse_vars_[incr n]" in $varnames} {} - return [concat $varnames pkguse_vars_$n] + #return [concat $varnames pkguse_vars_$n] + return [list {*}$varnames pkguse_vars_$n] } proc tracehandler_nowrite {args} { error "readonly in use block" diff --git a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index e38c76c6..54949ad4 100644 --- a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -1,5 +1,5 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# 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. @@ -18,12 +18,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::packagepreference 0 0.1.0] +#[manpage_begin punkshell_module_punk::packagepreference 0 0.1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] +#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] #[require punk::packagepreference] -#[keywords module] +#[keywords module package] #[description] #[para] - diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index bc93a9c3..db0911f4 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -710,7 +710,7 @@ namespace eval punk::repo { lappend col2_values [dict get $summary_dict $f] } set title1 "" - set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_fields] {string length $v}]] + set widest1 [tcl::mathfunc::max {*}[lmap v [list $title1 {*}$col1_fields] {string length $v}]] set col1 [string repeat " " $widest1] set title2 "" set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2_values] {string length $v}]] diff --git a/src/bootsupport/modules/punk/trie-0.1.0.tm b/src/bootsupport/modules/punk/trie-0.1.0.tm index 6f7f9d14..0b5bd298 100644 --- a/src/bootsupport/modules/punk/trie-0.1.0.tm +++ b/src/bootsupport/modules/punk/trie-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::trie 0 0.1.0] +#[manpage_begin punkshell_module_punk::trie 0 0.1.0] #[copyright "2010"] #[titledesc {punk::trie API}] [comment {-- Name section and table of contents description --}] #[moddesc {punk::trie}] [comment {-- Description at end of page heading --}] @@ -64,34 +64,34 @@ package require Tcl 8.6- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::trie::class { - #*** !doctools - #[subsection {Namespace punk::trie::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 ---}] - #} -#} +# #tcl::namespace::eval punk::trie::class { +# #*** !doctools +# #[subsection {Namespace punk::trie::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 ---}] +# #} +# #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -114,11 +114,18 @@ tcl::namespace::eval punk::trie { } #namespace path ::punk::trie::log - #[para] class definitions + #*** !doctools + #[subsection {Namespace punk::trie}] + #[para] Core API functions for punk::trie if {[tcl::info::commands [tcl::namespace::current]::trieclass] eq ""} { #*** !doctools #[list_begin enumerated] + oo::class create [tcl::namespace::current]::trieclass { + #*** !doctools + #[enum] CLASS [class trieclass] + #[list_begin definitions] + variable trie id method matches {t what} { @@ -412,9 +419,8 @@ tcl::namespace::eval punk::trie { } set acc {} - - foreach key [dict keys $t] { - lappend acc {*}[my flatten [dict get $t $key] $prefix$key] + dict for {key val} $t { + lappend acc {*}[my flatten $val $prefix$key] } return $acc } @@ -484,8 +490,14 @@ tcl::namespace::eval punk::trie { my insert $a } } + + #*** !doctools + #[list_end] [comment {--- end definitions ---}] } + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + set testlist [list blah x black blacken] proc test1 {} { #JMN @@ -516,14 +528,9 @@ tcl::namespace::eval punk::trie { # #[list_end] [comment {-- end definitions interface_sample1}] # } - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] } - #*** !doctools - #[subsection {Namespace punk::trie}] - #[para] Core API functions for punk::trie - #[list_begin definitions] + @@ -542,8 +549,6 @@ tcl::namespace::eval punk::trie { - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::trie ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/bootsupport/modules/punk/zip-0.1.1.tm index 2dc235ed..311a8025 100644 --- a/src/bootsupport/modules/punk/zip-0.1.1.tm +++ b/src/bootsupport/modules/punk/zip-0.1.1.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -11,7 +11,7 @@ # @@ Meta Begin # Application punk::zip 0.1.1 # Meta platform tcl -# Meta license +# Meta license MIT # @@ Meta End @@ -19,12 +19,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::zip 0 0.1.1] +#[manpage_begin punkshell_module_punk::zip 0 0.1.1] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::zip] -#[keywords module] +#[keywords module zip fileformat] #[description] #[para] - @@ -60,38 +60,6 @@ package require punk::args #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::zip::class { - #*** !doctools - #[subsection {Namespace punk::zip::class}] - #[para] class definitions - #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace @@ -541,37 +509,60 @@ tcl::namespace::eval punk::zip { #todo - doctools - [arg ?globs...?] syntax? #*** !doctools - #[call [fun mkzip] [arg ?options?] [arg filename] ] - #[para] Create a zip archive in 'filename' + #[call [fun mkzip]\ + # [opt "[option -offsettype] [arg offsettype]"]\ + # [opt "[option -return] [arg returntype]"]\ + # [opt "[option -zipkit] [arg 0|1]"]\ + # [opt "[option -runtime] [arg preamble_filename]"]\ + # [opt "[option -comment] [arg zipfilecomment]"]\ + # [opt "[option -directory] [arg dir_to_zip]"]\ + # [opt "[option -base] [arg archive_root]"]\ + # [opt "[option -exclude] [arg globlist]"]\ + # [arg zipfilename]\ + # [arg ?glob...?]] + #[para] Create a zip archive in 'zipfilename' #[para] If a file already exists, an error will be raised. + #[para] Call 'punk::zip::mkzip' with no arguments for usage display. + set argd [punk::args::get_dict { - *proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" + *proc -name punk::zip::mkzip\ + -help "Create a zip archive in 'filename'" *opts - -offsettype -default "archive" -choices {archive file} -help "zip offsets stored relative to start of entire file or relative to start of zip-archive + -offsettype -default "archive" -choices {archive file}\ + -help "zip offsets stored relative to start of entire file or relative to start of zip-archive Only relevant if the created file has a script/runtime prefix. " - -return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive - the option -return pretty is the default and uses the punk::lib pdict/plist system - to return a formatted list for the terminal - " - -zipkit -default 0 -type none -help "whether to add mounting script - mutually exclusive with -runtime option - currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs + -return -default "pretty" -choices {pretty list none}\ + -help "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal " - -runtime -default "" -help "specify a prefix file - e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip - will create a self-extracting zip archive from the subdir/ folder. - Expects runtime with no existing vfs attached (review) + -zipkit -default 0 -type none\ + -help "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs " - -comment -default "" -help "An optional comment for the archive" - -directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" - -base -default "" -help "The new zip archive will be rooted in this directory if provided - it must be a parent of -directory or the same path as -directory" + -runtime -default ""\ + -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review) + " + -comment -default ""\ + -help "An optional comment for the archive" + -directory -default ""\ + -help "The new zip archive will scan for contents within this folder or current directory if not provided." + -base -default ""\ + -help "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory or the same path as -directory" -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + *values -min 1 -max -1 - filename -type file -default "" -help "name of zipfile to create" - globs -default {*} -multiple 1 -help "list of glob patterns to match. - Only directories with matching files will be included in the archive" + filename -type file -default ""\ + -help "name of zipfile to create" + globs -default {*} -multiple 1\ + -help "list of glob patterns to match. + Only directories with matching files will be included in the archive." } $args] set filename [dict get $argd values filename] @@ -733,7 +724,7 @@ tcl::namespace::eval punk::zip { } set cdoffset [tell $zf] set endrec [binary format a4ssssiis PK\05\06 0 0 \ - $count $count [string length $cd] $cdoffset\ + $count $count [string length $cd] [expr {$cdoffset - $dataStartOffset}]\ [string length $opts(-comment)]] append endrec $opts(-comment) puts -nonewline $zf $cd @@ -793,17 +784,6 @@ tcl::namespace::eval punk::zip::lib { -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval punk::zip::system { - #*** !doctools - #[subsection {Namespace punk::zip::system}] - #[para] Internal functions that are not part of the API - - - -#} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::zip [tcl::namespace::eval punk::zip { diff --git a/src/bootsupport/modules/textblock-0.1.2.tm b/src/bootsupport/modules/textblock-0.1.2.tm index 8d24e650..2419f9fb 100644 --- a/src/bootsupport/modules/textblock-0.1.2.tm +++ b/src/bootsupport/modules/textblock-0.1.2.tm @@ -21,7 +21,7 @@ #[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] #[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] #[require textblock] -#[keywords module utility lib] +#[keywords module ansi text layout colour table frame console terminal] #[description] #[para] Ansi-aware terminal textblock manipulation @@ -180,7 +180,7 @@ tcl::namespace::eval textblock { variable table_edge_parts set table_edge_parts [tcl::dict::create\ topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ + topinner [struct::set intersect $C $tops]\ topright [struct::set intersect $O [concat $tops $rights]]\ topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ middleleft [struct::set intersect $L $lefts]\ @@ -201,22 +201,22 @@ tcl::namespace::eval textblock { #The usual-case of a single header line is the 'onlyleft,onlyinner,onlyright,onlysolo' set. variable header_edge_parts set header_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ + topleft [struct::set intersect $C [list {*}$tops {*}$lefts]]\ + topinner [struct::set intersect $C $tops]\ + topright [struct::set intersect $O [list {*}$tops {*}$rights]]\ + topsolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ middleleft [struct::set intersect $L $lefts]\ middleinner [list]\ middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts]]\ + middlesolo [struct::set intersect $U [list {*}$lefts {*}$rights]]\ + bottomleft [struct::set intersect $L $lefts]\ bottominner [list]\ bottomright [struct::set intersect $U $rights]\ - bottomsolo [struct::set intersect $U [concat $lefts $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts]]\ + bottomsolo [struct::set intersect $U [list {*}$lefts {*}$rights]]\ + onlyleft [struct::set intersect $C [list {*}$tops {*}$lefts]]\ onlyinner [struct::set intersect $C $tops]\ - onlyright [struct::set intersect $O [concat $tops $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $rights]]\ + onlyright [struct::set intersect $O [list {*}$tops {*}$rights]]\ + onlysolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ ] variable table_hseps set table_hseps [tcl::dict::create\ @@ -321,9 +321,17 @@ tcl::namespace::eval textblock { set switch_keys_valid_copts [lrange $switch_keys_valid_copts 0 end-1] oo::class create [tcl::namespace::current]::table [tcl::string::map [list %topt_keys% $topt_keys %topt_switchkeys% $switch_keys_valid_topts %copt_keys% $copt_keys %copt_switchkeys% $switch_keys_valid_copts] { + #*** !doctools #[enum] CLASS [class textblock::class::table] #[list_begin definitions] + #[para] Create a table suitable for terminal output with various border styles. + #[para] The table can contain multiline cells and ANSI colour and text style attributes. + #[para] Multiple header rows can be configured. + #[para] Header rows can span columns - data rows cannot. + #[para] The restriction on data rows is to maintain compatibility of the data with a Tcl matrix command + #[para] (see get_matrix command) + #[para] Both header and data cells can have various text and blockalignments configured. # [para] [emph METHODS] variable o_opts_table ;#options as configured by user (with exception of -ansireset) variable o_opts_table_effective; #options in effect - e.g with defaults merged in. @@ -348,6 +356,8 @@ tcl::namespace::eval textblock { constructor {args} { #*** !doctools #[call class::table [method constructor] [arg args]] + #[para] TODO - document the many options + set o_opts_table_defaults $::textblock::class::opts_table_defaults set o_opts_column_defaults $::textblock::class::opts_column_defaults @@ -452,6 +462,22 @@ tcl::namespace::eval textblock { set ft_body light } } + light_b { + if {$requested_ft_header eq ""} { + set ft_header heavy_b + } + if {$requested_ft_body eq ""} { + set ft_body light_b + } + } + light_c { + if {$requested_ft_header eq ""} { + set ft_header heavy_c + } + if {$requested_ft_body eq ""} { + set ft_body light_c + } + } default { if {$requested_ft_header eq ""} { set ft_header $requested_ft @@ -525,6 +551,10 @@ tcl::namespace::eval textblock { return [tcl::dict::create body $blims header $hlims] } method configure args { + #*** !doctools + #[call class::table [method configure] [arg args]] + #[para] get or set various table-level properties + if {![llength $args]} { return $o_opts_table } @@ -744,6 +774,11 @@ tcl::namespace::eval textblock { #integrate with struct::matrix - allows ::m format 2string $table method printmatrix {matrix} { + #*** !doctools + #[call class::table [method printmatrix] [arg matrix]] + #[para] clear all table rows and print a matrix into the table + #[para] The rowxcolumn structure must match + set matrix_rowcount [$matrix rows] set matrix_colcount [$matrix columns] set table_colcount [my column_count] @@ -765,6 +800,10 @@ tcl::namespace::eval textblock { my print } method as_matrix {{cmd ""}} { + #*** !doctools + #[call class::table [method as_matrix] [arg ?cmd?]] + #[para] return a struct::matrix command representing the data portion of the table. + if {$cmd eq ""} { set m [struct::matrix] } else { @@ -832,9 +871,16 @@ tcl::namespace::eval textblock { return $colcount } method column_count {} { + #*** !doctools + #[call class::table [method column_count]] + #[para] return the number of columns return [tcl::dict::size $o_columndefs] } method configure_column {index_expression args} { + #*** !doctools + #[call class::table [method configure_column] [arg index_expression] [arg args]] + #[para] - undocumented + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" @@ -1055,6 +1101,9 @@ tcl::namespace::eval textblock { } method header_count {} { + #*** !doctools + #[call class::table [method header_count]] + #[para] return the number of header rows return [tcl::dict::size $o_headerstates] } method header_count_calc {} { @@ -1066,6 +1115,10 @@ tcl::namespace::eval textblock { return $max_headers } method header_height {header_index} { + #*** !doctools + #[call class::table [method header_height] [arg header_index]] + #[para] return the height of a header as the number of content-lines + set idx [lindex [tcl::dict::keys $o_headerstates $header_index]] return [tcl::dict::get $o_headerstates $idx maxheightseen] } @@ -1097,6 +1150,10 @@ tcl::namespace::eval textblock { # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} # method header_colspans {} { + #*** !doctools + #[call class::table [method header_colspans]] + #[para] Show the colspans configured for all headers + #set num_headers [my header_count_calc] set num_headers [my header_count] set colspans_by_header [tcl::dict::create] @@ -1177,6 +1234,10 @@ tcl::namespace::eval textblock { #should be configure_headerrow ? method configure_header {index_expression args} { + #*** !doctools + #[call class::table [method configure_header]] + #[para] - undocumented + #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis #e.g o_headerstates: 0 {maxheightseen 1} 1 {maxheightseen 2} @@ -1448,7 +1509,12 @@ tcl::namespace::eval textblock { method add_row {valuelist args} { #*** !doctools - #[call class::table [method add_row] [arg args]] + #[call class::table [method add_row]\ + # [arg valuelist]\ + # [opt "[option -minheight] [arg int_minheight]"]\ + # [opt "[option -maxheight] [arg int_maxheight]"]\ + # [opt "[option -ansibase] [arg ansicode]"]\ + #] if {[tcl::dict::size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [tcl::dict::size $o_columndefs])} { set msg "" append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [tcl::dict::size $o_columndefs]" \n @@ -1523,16 +1589,15 @@ tcl::namespace::eval textblock { set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] tcl::dict::lappend o_columndata $c $v - set valheight [textblock::height $v] + lassign [textblock::size_as_list $v] valwidth valheight if {$valheight > $max_height_seen} { set max_height_seen $valheight } - set width [textblock::width $v] - if {$width > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { - tcl::dict::set o_columnstates $c maxwidthbodyseen $width + if {$valwidth > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { + tcl::dict::set o_columnstates $c maxwidthbodyseen $valwidth } - if {$width < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { - tcl::dict::set o_columnstates $c minwidthbodyseen $width + if {$valwidth < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { + tcl::dict::set o_columnstates $c minwidthbodyseen $valwidth } if {[tcl::dict::get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [tcl::dict::get $o_columnstates $c minwidthbodyseen] < $prev_minwidth} { @@ -1552,6 +1617,13 @@ tcl::namespace::eval textblock { return $rowcount } method configure_row {index_expression args} { + #*** !doctools + #[call class::table [method configure_row]\ + # [arg index_expression]\ + # [opt "[option -minheight] [arg int_minheight]"]\ + # [opt "[option -maxheight] [arg int_maxheight]"]\ + # [opt "[option -ansibase] [arg ansicode]"]\ + #] set ridx [lindex [tcl::dict::keys $o_rowdefs] $index_expression] if {$ridx eq ""} { error "textblock::table::configure_row - no row defined at index '$ridx'.Use add_row to define rows" @@ -1640,9 +1712,16 @@ tcl::namespace::eval textblock { tcl::dict::set o_rowdefs $ridx $opts } method row_count {} { + #*** !doctools + #[call class::table [method row_count]] + #[para] return the number of data rows in the table. return [tcl::dict::size $o_rowdefs] } method row_clear {} { + #*** !doctools + #[call class::table [method row_clear]] + #[para] Remove all rows without resetting column data. + #[para] When adding new rows the number of entries will need to match the existing column count. set o_rowdefs [tcl::dict::create] set o_rowstates [tcl::dict::create] #The data values are stored by column regardless of whether added row by row @@ -1655,6 +1734,12 @@ tcl::namespace::eval textblock { set o_calculated_column_widths [list] } method clear {} { + #*** !doctools + #[call class::table [method clear]] + #[para] Remove all row and column data. + #[para] If a subsequent call to add_row is made it can contain any number of values. + #[para] Further calls to add_row will need to contain the same number of values + #[para] as the first call unless default values have been set for the missing columns (review - in flux). my row_clear set o_columndefs [tcl::dict::create] set o_columndata [tcl::dict::create] @@ -2000,7 +2085,7 @@ tcl::namespace::eval textblock { #just write an empty vertical placeholder. The spanned value will be overtyped below set cellcontents [::join [lrepeat [llength [split $hval \n]] ""] \n] } - set header_cell_startspan [textblock::frame -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ + set header_cell_startspan [textblock::frame -checkargs 0 -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ -ansibase $ansibase_header -ansiborder $ansiborder_final\ -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ ] @@ -2134,7 +2219,7 @@ tcl::namespace::eval textblock { #set spacemap [list hl * vl * tlc * blc * trc * brc *] #-usecache 1 ok #hval is not raw headerval - it has been padded to required width and has ansi applied - set hblock [textblock::frame -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase + set hblock [textblock::frame -checkargs 0 -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase #puts "==>boxlimits:'$hlims' hval_width:[tcl::string::length $hval] blockwidth:[textblock::width $hblock]" #puts $hblock #puts "==>hval:'$hval'[a]" @@ -2199,7 +2284,7 @@ tcl::namespace::eval textblock { # -usecache 1 ok #frame borders will never display - so use the simplest frametype and don't apply any ansi #puts "===>zerospan hlims: $hlims" - set header_frame [textblock::frame -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ + set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ ] } @@ -2220,7 +2305,7 @@ tcl::namespace::eval textblock { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts only$opt_posn] ] } set header_joins $header_body_joins - set header_frame [textblock::frame -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ + set header_frame [textblock::frame -checkargs 0 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ -ansibase $ansibase_header -ansiborder $ansiborder_final\ -boxlimits $hlims -boxmap $hdrmap -joins $header_joins\ ] @@ -2366,7 +2451,7 @@ tcl::namespace::eval textblock { set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] } } - set rowframe [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] + set rowframe [textblock::frame -checkargs 0 -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] set return_bodywidth [textblock::widthtopline $rowframe] ;#frame lines always same width - just look at top line append part_body $rowframe \n } else { @@ -2384,7 +2469,7 @@ tcl::namespace::eval textblock { set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] } } - append part_body [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n + append part_body [textblock::frame -checkargs 0 -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n } incr r } @@ -2411,7 +2496,7 @@ tcl::namespace::eval textblock { append part_body [tcl::string::repeat " " $colwidth] \n set return_bodywidth $colwidth } else { - set emptyframe [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] + set emptyframe [textblock::frame -checkargs 0 -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] append part_body $emptyframe \n set return_bodywidth [textblock::width $emptyframe] } @@ -2441,6 +2526,10 @@ tcl::namespace::eval textblock { } method get_column_cells_by_index {index_expression} { + #*** !doctools + #[call class::table [method get_column_cells_by_index] [arg index_expression]] + #[para] Return a dict with keys 'headers' and 'cells' giving column header and data values + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { set range "" @@ -2499,7 +2588,9 @@ tcl::namespace::eval textblock { set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] set hval_lines [split $hdr \n] - set hval_lines [concat $hval_lines $hcell_lines] + #jmn concat + #set hval_lines [concat $hval_lines $hcell_lines] + set hval_lines [list {*}$hval_lines {*}$hcell_lines] set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top set hval_block [::join $hval_lines \n] set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] @@ -2556,12 +2647,14 @@ tcl::namespace::eval textblock { set cval_lines [split $cval \n] - set cval_lines [concat $cval_lines $cell_lines] + #jmn + #set cval_lines [concat $cval_lines $cell_lines] + lappend cval_lines {*}$cell_lines set cval_lines [lrange $cval_lines 0 $rowh-1] set cval_block [::join $cval_lines \n] - - set cell [textblock::pad $cval_block -width $datawidth -padchar " " -within_ansi 1 -which $pad] + #//JMN assert widest cval_line = datawidth = known_blockwidth + set cell [textblock::pad $cval_block -known_blockwidth $datawidth -width $datawidth -padchar " " -within_ansi 1 -which $pad] #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] tcl::dict::lappend output cells $cell @@ -2570,6 +2663,10 @@ tcl::namespace::eval textblock { return $output } method get_column_values_by_index {index_expression} { + #*** !doctools + #[call class::table [method get_column_values_by_index] [arg index_expression]] + #[para] List the cell values of a column from the data area only (no header values) + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { return @@ -2577,6 +2674,10 @@ tcl::namespace::eval textblock { return [tcl::dict::get $o_columndata $cidx] } method debug {args} { + #*** !doctools + #[call class::table [method debug]] + #[para] display lots of debug information about how the table is constructed. + #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) set defaults [tcl::dict::create\ -usetables 1\ @@ -2759,12 +2860,20 @@ tcl::namespace::eval textblock { } method column_width {index_expression} { + #*** !doctools + #[call class::table [method column_width] [arg index_expression]] + #[para] inner width of column ie the available cell-width without borders/separators + if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { my calculate_column_widths -algorithm $o_column_width_algorithm } return [lindex $o_calculated_column_widths $index_expression] } method column_widths {} { + #*** !doctools + #[call class::table [method column_width]] + #[para] ordered list of column widths (inner widths) + if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { my calculate_column_widths -algorithm $o_column_width_algorithm } @@ -2774,7 +2883,12 @@ tcl::namespace::eval textblock { #width of a table includes borders and seps #whereas width of a column refers to the borderless width (inner width) method width {} { - #calculate width based on assumption frame verticals are 1-wide - review - what about custom unicode double-wide frame? + #*** !doctools + #[call class::table [method width]] + #[para] width of the table including borders and separators + #[para] calculate width based on assumption frame verticals are 1 screen-column wide + #[para] (review - consider possibility of custom unicode double-wide frame?) + set colwidths [my column_widths] set contentwidth [tcl::mathop::+ {*}$colwidths] set twidth $contentwidth @@ -3284,6 +3398,11 @@ tcl::namespace::eval textblock { #spangroups keyed by column method spangroups {} { + #*** !doctools + #[call class::table [method spangroups]] + #[para] return a dict keyed by column-index showing advanced span information + #[para] (debug tool) + set column_count [tcl::dict::size $o_columndefs] set spangroups [tcl::dict::create] set headerwidths [tcl::dict::create] ;#key on col,hrow @@ -3655,6 +3774,10 @@ tcl::namespace::eval textblock { #print headers and body using different join mechanisms # using -startcolumn to do slightly less work method print {args} { + #*** !doctools + #[call class::table [method print]] + #[para] Return the table as text suitable for console display + if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] } else { @@ -3775,6 +3898,14 @@ tcl::namespace::eval textblock { } } method print_bodymatrix {} { + #*** !doctools + #[call class::table [method print_bodymatrix]] + #[para] output the matrix string corresponding to the body data using the matrix 2string format + #[para] this will be a table without borders,headers,title etc and will exclude additional ANSI applied due to table, row or column settings. + #[para] If the original cell data itself contains ANSI - the output will still contain those ansi codes. + # + + set m [my as_matrix] $m format 2string } @@ -3793,6 +3924,14 @@ tcl::namespace::eval textblock { #Note: A textblock does not necessarily have lines the same length - either in number of characters or print-width # tcl::namespace::eval textblock { + variable frametypes + set frametypes [list light light_b light_c heavy heavy_b heavy_c arc arc_b arc_c double block block1 block2 block2hack ascii altg] + #class::table needs to be able to determine valid frametypes + proc frametypes {} { + variable frametypes + return $frametypes + } + tcl::namespace::eval cd { #todo - save and restore existing tcl::namespace::export in case macros::cd has default exports in future tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export *} @@ -4020,7 +4159,7 @@ tcl::namespace::eval textblock { if {[dict get $opts -frame]} { #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - set output [textblock::frame -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] } else { set output [$t print] } @@ -4030,50 +4169,52 @@ tcl::namespace::eval textblock { return $t } - proc list_as_table {args} { - set argd [punk::args::get_dict [string map [list $::textblock::frametypes] { - -return -default table -choices {table tableobject} - -frametype -default "" -help "frame type: or dict for custom frame" - -show_edge -default "" -type boolean -help "show outer border of table" - -show_seps -default "" -type boolean - -show_vseps -default "" -type boolean -help "Show vertical table separators" - -show_hseps -default "" -type boolean -help "Show horizontal table separators + set FRAMETYPES [textblock::frametypes] + punk::args::Get_argspecs [punk::lib::tstr -return string { + *id textblock::list_as_table + + -return -default table -choices {table tableobject} + -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ + -help "frame type or dict for custom frame" + -show_edge -default "" -type boolean\ + -help "show outer border of table" + -show_seps -default "" -type boolean + -show_vseps -default "" -type boolean\ + -help "Show vertical table separators" + -show_hseps -default "" -type boolean\ + -help "Show horizontal table separators (default 0 if no existing -table supplied)" - -table -default "" -type string -help "existing table object to use" - -colheaders -default "" -type list -help "list of lists. list of column header values. Outer list must match number of columns" - -header -default "" -type list -multiple 1 -help "Headers left to right" - -show_header -default "" -help "Whether to show a header row. - Leave as empty string for unspecified/automatic, - in which case it will display only if -headers list was supplied." - -action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied + -table -default "" -type string\ + -help "existing table object to use" + -colheaders -default "" -type list\ + -help "list of lists. list of column header values. Outer list must match number of columns" + -header -default "" -type list -multiple 1\ + -help "Each supplied -header argument is a header row. + The number of values for each must be <= number of columns" + -show_header -default ""\ + -help "Whether to show a header row. + Leave as empty string for unspecified/automatic, + in which case it will display only if -headers list was supplied." + -action -default "append" -choices {append replace}\ + -help "row insertion method if existing -table is supplied if append is chosen the new values will always start at the first column" - -columns -default "" -type integer -help "Number of table columns + -columns -default "" -type integer\ + -help "Number of table columns Will default to 2 if not using an existing -table object" - *values -min 0 -max 1 - datalist -default {} -help "flat list of table cell values which will be wrapped based on -columns value" - }] $args] + + *values -min 0 -max 1 + datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value" + }] + + proc list_as_table {args} { + set FRAMETYPES [textblock::frametypes] + set argd [punk::args::get_dict_by_id textblock::list_as_table $args] + set opts [dict get $argd opts] set datalist [dict get $argd values datalist] set existing_table [dict get $opts -table] set opt_columns [dict get $opts -columns] - #set opts [tcl::dict::create\ - # -return string\ - # -frametype \uFFEF\ - # -show_edge \uFFEF\ - # -show_seps \uFFEF\ - #] - #foreach {k v} $args { - # switch -- $k { - # -return - -show_edge - -show_seps - -frametype { - # tcl::dict::set opts $k $v - # } - # default { - # error "unrecognised option '$k'. Known options [tcl::dict::keys $opts]" - # } - # } - #} - set count [llength $datalist] set is_new_table 0 @@ -4167,15 +4308,12 @@ tcl::namespace::eval textblock { } } #defaults for new table only - if {[tcl::dict::get $opts -frametype] eq ""} { - tcl::dict::set opts -frametype "light" - } + #if {[tcl::dict::get $opts -show_seps] eq ""} { + # tcl::dict::set opts -show_seps 1 + #} if {[tcl::dict::get $opts -show_edge] eq ""} { tcl::dict::set opts -show_edge 1 } - if {[tcl::dict::get $opts -show_seps] eq ""} { - tcl::dict::set opts -show_seps 1 - } if {[tcl::dict::get $opts -show_vseps] eq ""} { tcl::dict::set opts -show_vseps 1 } @@ -4224,7 +4362,8 @@ tcl::namespace::eval textblock { foreach row $rowdata { set shortfall [expr {$cols - [llength $row]}] if {$shortfall > 0} { - set row [concat $row [lrepeat $shortfall ""]] + #set row [concat $row [lrepeat $shortfall ""]] + lappend row {*}[lrepeat $shortfall ""] } $t add_row $row } @@ -4307,7 +4446,7 @@ tcl::namespace::eval textblock { - set chars [concat [punk::lib::range 1 9] A B C D E F] + set chars [list {*}[punk::lib::range 1 9] A B C D E F] set charsubset [lrange $chars 0 $size-1] if {"noreset" in $colour} { set RST "" @@ -4386,6 +4525,37 @@ tcl::namespace::eval textblock { } return [punk::char::ansifreestring_width $textblock] } + #gather info about whether ragged (samewidth each line = false) and min width + proc widthinfo {textblock} { + #backspaces, vertical tabs ? + if {$textblock eq ""} { + return [dict create width 0 minwidth 0 ragged 0] + } + #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review + if {[tcl::string::last \t $textblock] >= 0} { + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set textblock [textutil::tabify::untabify2 $textblock $tw] + } + if {[punk::ansi::ta::detect $textblock]} { + #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + #return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + set widths [lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}] + set max [tcl::mathfunc::max {*}$widths] + set min [tcl::mathfunc::min {*}$widths] + set ragged [expr {$min != $max}] + return [dict create width $max minwidth $min ragged $ragged] + } + #single line + set w [punk::char::ansifreestring_width $textblock] + return [dict create width $w minwidth $w ragged 0] + } #when we know the block is uniform in width - just examine topline proc widthtopline {textblock} { set firstnl [tcl::string::first \n $textblock] @@ -4489,17 +4659,22 @@ tcl::namespace::eval textblock { set opts [tcl::dict::create\ -padchar " "\ -which "right"\ + -known_blockwidth ""\ + -known_samewidth ""\ + -known_hasansi ""\ -width ""\ -overflow 0\ -within_ansi 0\ ] + #known_samewidth of empty string means we don't know either way, 0 is definitely 'ragged', 1 is definitely homogenous + #review!? #-within_ansi means after a leading ansi code when doing left pad on all but last line #-within_ansi means before a trailing ansi code when doing right pad on all but last line - set usage "pad ?-padchar |? ?-which right|left|centre? ?-width auto|? ?-within_ansi 1|0?" + set usage "pad ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" foreach {k v} $args { switch -- $k { - -padchar - -which - -width - -overflow - -within_ansi { + -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { tcl::dict::set opts $k $v } default { @@ -4551,11 +4726,38 @@ tcl::namespace::eval textblock { } } # -- --- --- --- --- --- --- --- --- --- - - set datawidth [textblock::width $block] + set known_blockwidth [tcl::dict::get $opts -known_blockwidth] + set known_samewidth [tcl::dict::get $opts -known_samewidth] ;# if true - we have a known non-ragged block, if false - could be either. + set datawidth "" if {$width eq "auto"} { - set width $datawidth + #for auto - we + if {$known_blockwidth eq ""} { + if {$known_samewidth ne "" && $known_samewidth} { + set datawidth [textblock::widthtopline $block] + } else { + #set datawidth [textblock::width $block] + set widthinfo [textblock::widthinfo $block] + set known_samewidth [expr {![dict get $widthinfo ragged]}] ;#review - a false value here is definite, distinguished from unknown which would be empty string - so we can take advantage of it + set datawidth [dict get $widthinfo width] + } + } else { + set datawidth $known_blockwidth + } + set width $datawidth ;# this is the width we want to pad out to + #assert datawidth has been set to widest line, taking ansi & 2wide chars into account + } else { + #only call width functions if known_samewidth - otherwise let the pad algorithm below determine it as we go + if {$known_samewidth ne "" && $known_samewidth} { + if {$known_blockwidth eq ""} { + set datawidth [textblock::widthtopline $block + } else { + set datawidth $known_blockwidth + } + } + #assert datawidth may still be empty string } + #assertion + #we can now use the states of datawidth and known_samewidth to determine if algorithm below should calculate widths as it goes. set lines [list] @@ -4578,39 +4780,45 @@ tcl::namespace::eval textblock { #review - tcl format can only pad with zeros or spaces? #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - if 0 { - #review - surprisingly, this doesn't seem to be a performance win - #No detectable diff on small blocks - slightly worse on large blocks - if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { - #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position - #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. - set block [tcl::string::map [list \r\n \n] $block] - if {$which eq "l"} { - set fmt "%+${padchar}*s" - } else { - set fmt "%-${padchar}*s" - } - foreach ln [split $block \n] { - #set lnwidth [punk::char::ansifreestring_width $ln] - set lnwidth [punk::char::grapheme_width_cached $ln] - set lnlen [tcl::string::length $ln] - set diff [expr $lnwidth - $lnlen] - #we need trickwidth to get format to pad a string with a different terminal width compared to string length - set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) - lappend lines [format $fmt $trickwidth $ln] - } - return [::join $lines \n] - } - } + #review - surprisingly, this doesn't seem to be a performance win + #No detectable diff on small blocks - slightly worse on large blocks + # if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { + # #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position + # #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. + # set block [tcl::string::map [list \r\n \n] $block] + # if {$which eq "l"} { + # set fmt "%+${padchar}*s" + # } else { + # set fmt "%-${padchar}*s" + # } + # foreach ln [split $block \n] { + # #set lnwidth [punk::char::ansifreestring_width $ln] + # set lnwidth [punk::char::grapheme_width_cached $ln] + # set lnlen [tcl::string::length $ln] + # set diff [expr $lnwidth - $lnlen] + # #we need trickwidth to get format to pad a string with a different terminal width compared to string length + # set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) + # lappend lines [format $fmt $trickwidth $ln] + # } + # return [::join $lines \n] + # } #todo? special case trailing double-reset - insert between resets? set lnum 0 - if {[punk::ansi::ta::detect $block]} { + + set known_hasansi [tcl::dict::get $opts -known_hasansi] + if {$known_hasansi eq ""} { + set block_has_ansi [punk::ansi::ta::detect $block] + } else { + set block_has_ansi $known_hasansi + } + if {$block_has_ansi} { set parts [punk::ansi::ta::split_codes $block] } else { #single plaintext part set parts [list $block] } + set line_chunks [list] set line_len 0 set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad @@ -4628,10 +4836,16 @@ tcl::namespace::eval textblock { foreach pl $partlines { lappend line_chunks $pl #incr line_len [punk::char::ansifreestring_width $pl] - incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + } if {$p != $last} { #do padding - set missing [expr {$width - $line_len}] + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + set missing [expr {$width - $line_len}] + } else { + set missing [expr {$width - $datawidth}] + } if {$missing > 0} { #commonly in a block - many lines will have the same pad - cache based on missing @@ -4702,7 +4916,11 @@ tcl::namespace::eval textblock { } } #pad last line - set missing [expr {$width - $line_len}] + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + set missing [expr {$width - $line_len}] + } else { + set missing [expr {$width - $datawidth}] + } if {$missing > 0} { if {[tcl::dict::exists $pad_cache $missing]} { set pad [tcl::dict::get $pad_cache $missing] @@ -4788,12 +5006,12 @@ tcl::namespace::eval textblock { proc pad_test {block} { set width [textblock::width $block] set padtowidth [expr {$width + 10}] - set left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - set left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - set left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - set right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - set right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - set right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] + set left0 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 0] + set left1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 1] + set left2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 2] + set right0 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 0] + set right1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 1] + set right2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 2] set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] @@ -4997,6 +5215,50 @@ tcl::namespace::eval textblock { # -- is a legimate block #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) + if {![llength $blocks]} { + return + } + set rowcount 0 + set blocklists [list] + foreach b $blocks { + if {[punk::ansi::ta::detect $b]} { + #-ansireplays 1 quite expensive e.g 7ms in 2024 + set bl [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] + } else { + set bl [split $b \n] + } + if {[llength $bl] > $rowcount} { + set rowcount [llength $bl] + } + lappend blocklists $bl + } + set outlines [list] + for {set r 0} {$r < $rowcount} {incr r} { + set row "" + for {set c 0} {$c < [llength $blocks]} {incr c} { + append row [lindex $blocklists $c $r] + } + lappend outlines $row + } + return [::join $outlines \n] + } + proc ::textblock::join_basic2 {args} { + #*proc -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. + # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner + #" + set argd [punk::args::get_dict { + -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" + -ansiresets -type any -default auto + blocks -type any -multiple 1 + } $args] + set ansiresets [tcl::dict::get $argd opts -ansiresets] + set blocks [tcl::dict::get $argd values blocks] + + #-ansireplays is always on (if ansi detected) + + # -- is a legimate block + #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) + if {![llength $blocks]} { return } @@ -5068,6 +5330,188 @@ tcl::namespace::eval textblock { return } + set idx 0 + set blocklists [list] + set rowcount 0 + foreach b $blocks { + #we need the width of a rendered block for per-row renderline calls or padding + #we may as well use widthinfo to also determine raggedness state to pass on to pad function + #set bwidth [width $b] + set widthinfo [widthinfo $b] + set bwidth [dict get $widthinfo width] + set is_samewidth [expr {![dict get $widthinfo ragged]}] + + #set c($idx) [tcl::string::repeat " " [set w($idx)]] + #fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n- + #for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi. + #testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway. + + #blocks passed to join can be ragged - so we can't pass -known_samewidth to pad + if {[punk::ansi::ta::detect $b]} { + # - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?) + set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n] + set bl [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] + } else { + #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi + set bl [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] + } + set rowcount [expr {max($rowcount,[llength $bl])}] + lappend blocklists $bl + set width($idx) $bwidth + incr idx + } + + set outlines [list] + for {set r 0} {$r < $rowcount} {incr r} { + set row "" + for {set c 0} {$c < [llength $blocklists]} {incr c} { + set cell [lindex $blocklists $c $r] + if {$cell eq ""} { + set cell [string repeat " " $width($c)] + } + append row $cell + } + lappend outlines $row + } + return [::join $outlines \n] + } + + proc ::textblock::join2 {args} { + #set argd [punk::args::get_dict { + # blocks -type string -multiple 1 + #} $args] + #set opts [tcl::dict::get $argd opts] + #set blocks [tcl::dict::get $argd values blocks] + + #-ansireplays is always on (if ansi detected) + + #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets + #textblock::join is already somewhat expensive - we don't want to do much argument processing + #also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation + #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) + set ansiresets auto + switch -- [lindex $args 0] { + -- { + set blocks [lrange $args 1 end] + } + -ansiresets { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory." + } + } + default { + if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} { + error "first flag must be -ansiresets or end of opts marker --" + } else { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory" + } + } + } + } + + if {![llength $blocks]} { + return + } + + set idx 0 + set fordata [list] + set colindices [list] + foreach b $blocks { + set w($idx) [width $b] ;#we need the width of a rendered block for per-row renderline calls or padding + #set c($idx) [tcl::string::repeat " " [set w($idx)]] + #fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n- + #for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi. + #testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway. + if {[punk::ansi::ta::detect $b]} { + #lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] + + # - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?) + set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n] + lappend fordata "v($idx)" [split [textblock::pad $replay_block -known_hasansi 1 -known_blockwidth $w($idx) -width $w($idx) -which right -padchar " "] \n] + } else { + #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi + #lappend fordata "v($idx)" [split $b \n] + lappend fordata "v($idx)" [split [textblock::pad $b -known_hasansi 0 -known_blockwidth $w($idx) -width $w($idx) -which right -padchar " "] \n] + } + lappend colindices $idx + incr idx + } + + + + + set outlines [list] + #set colindices [lsort -integer -increasing [array names c]] + foreach {*}$fordata { + set row "" + foreach colidx $colindices { + #we know we have a single line, no ansi in underlay and no overflow required - so we can use renderline directly + #append row [overtype::renderline -width $w($colidx) -insert_mode 0 -info 0 $c($colidx) $v($colidx)] + #append row [textblock::pad $v($colidx) -width $w($colidx) -which right -padchar " "] + + #short blocks need to have empty lines padded too + if {$v($colidx) eq ""} { + append row [string repeat " " $w($colidx)] + } else { + append row $v($colidx) + } + } + lappend outlines $row + } + return [::join $outlines \n] + } + # This calls textblock::pad per cell :/ + proc ::textblock::join3 {args} { + #set argd [punk::args::get_dict { + # blocks -type string -multiple 1 + #} $args] + #set opts [tcl::dict::get $argd opts] + #set blocks [tcl::dict::get $argd values blocks] + + #-ansireplays is always on (if ansi detected) + + #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets + #textblock::join is already somewhat expensive - we don't want to do much argument processing + #also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation + #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) + set ansiresets auto + switch -- [lindex $args 0] { + -- { + set blocks [lrange $args 1 end] + } + -ansiresets { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory." + } + } + default { + if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} { + error "first flag must be -ansiresets or end of opts marker --" + } else { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory" + } + } + } + } + + if {![llength $blocks]} { + return + } + set idx 0 set fordata [list] set colindices [list] @@ -5097,6 +5541,7 @@ tcl::namespace::eval textblock { } lappend outlines $row } + #puts stderr "--->outlines len: [llength $outlines]" return [::join $outlines \n] } @@ -5122,7 +5567,7 @@ tcl::namespace::eval textblock { set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] set testblock [textblock::testblock 15 rainbow] set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] - set framed [textblock::frame -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] + set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] } @@ -5163,13 +5608,13 @@ tcl::namespace::eval textblock { append out $punks \n append out $cpunks \n append out [textblock::join -- $punks $cpunks] \n - set 2frames_a [textblock::join -- [textblock::frame $cpunks] [textblock::frame $punks]] + set 2frames_a [textblock::join -- [textblock::frame -checkargs 0 $cpunks] [textblock::frame -checkargs 0 $punks]] append out $2frames_a \n - set 2frames_b [textblock::join -- [textblock::frame -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -ansiborder $greenb -title "fancypunks" $cpunks]] - append out [textblock::frame -title "punks" $2frames_b\n$RST$2frames_a] \n - set fancy [overtype::right [overtype::left [textblock::frame -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nL\nI\nF\nE"] + set 2frames_b [textblock::join -- [textblock::frame -checkargs 0 -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -checkargs 0 -ansiborder $greenb -title "fancypunks" $cpunks]] + append out [textblock::frame -checkargs 0 -title "punks" $2frames_b\n$RST$2frames_a] \n + set punkdeck [overtype::right [overtype::left [textblock::frame -checkargs 0 -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nD\nE\nC\nK"] set spantable [[spantest] print] - append out [textblock::join -- $fancy " " $spantable] \n + append out [textblock::join -- $punkdeck " " $spantable] \n #append out [textblock::frame -title gr $gr0] append out [textblock::periodic -forcecolour $opt_forcecolour] return $out @@ -5242,17 +5687,10 @@ tcl::namespace::eval textblock { } } - variable frametypes - set frametypes [list light heavy arc double block block1 block2 block2hack ascii altg] - #class::table needs to be able to determine valid frametypes - proc frametypes {} { - variable frametypes - return $frametypes - } proc frametype {f} { #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] switch -- $f { - light - heavy - arc - double - block - block1 - block2 - block2hack - ascii - altg { + light - light_b - light_c - heavy - heavy_b - heavy_c - arc - arc_b - arc_c - double - block - block1 - block2 - block2hack - ascii - altg { return [tcl::dict::create category predefined type $f] } default { @@ -5262,6 +5700,9 @@ tcl::namespace::eval textblock { foreach {k v} $f { switch -- $k { hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + hltj - hlbj - vllj - vlrj { + #also allow extra join arguments + } default { #k not in custom_keys set is_custom_dict_ok 0 @@ -5295,8 +5736,6 @@ tcl::namespace::eval textblock { return [tcl::dict::get $framedef_cache $cache_key] } - set argopts [lrange $args 0 end-1] - set f [lindex $args end] #here we avoid the punk::args usage on the happy path, even though punk::args is fairly fast, in favour of an even faster literal switch on the happy path #this means we have some duplication in where our flags/opts are defined: here in opts, and in spec below to give nicer error output without affecting performance. @@ -5306,29 +5745,101 @@ tcl::namespace::eval textblock { -boxonly 0\ ] set bad_option 0 - foreach {k v} $argopts { - switch -- $k { + set values [list] + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + set a2 [tcl::prefix match -error "" {-- -joins -boxonly} $a] + switch -- $a2 { -joins - -boxonly { - tcl::dict::set opts $k $v + tcl::dict::set opts $a2 [lindex $args [incr i]] + } + -- { + set values [lrange $args $i+1 end] + break } default { - set bad_option + if {[string match -* $a]} { + set bad_option 1 + } else { + set values [lrange $args $i end] + } break } } } - if {[llength $args] % 2 == 0 || $bad_option} { + set f [lindex $values 0] + set rawglobs [lrange $values 1 end] + if {![llength $rawglobs]} { + set globs * + } else { + set globs [list] + foreach g $rawglobs { + switch -- $g { + hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - + hltj - hlbj - vllj - vlrj { + lappend globs $g + } + corner - corners { + lappend globs tlc blc trc brc + } + noncorner - noncorners { + #same as verticals + horizontals + lappend globs hl* vl* + } + vertical - verticals { + #we don't consider the corners part of this + lappend globs vl* + } + horizontal - horizontals { + lappend globs hl* + } + top - tops { + lappend globs tlc trc hlt* + } + bottom - bottoms { + lappend globs blc brc hlb* + } + left - lefts - lhs { + lappend globs tlc blc vll* + } + right - rights - rhs { + lappend globs trc brc vlr* + } + default { + #must look like a glob search if not one of the above + if {[regexp {[*?\[\]]} $g]} { + lappend globs $g + } else { + set bad_option 1 + } + } + } + } + } + if {$bad_option || [llength $values] == 0} { #no framedef supplied, or unrecognised opt seen set spec [string map [list $::textblock::frametypes] { - *proc -name textblock::framedef - -joins -default "" -help "List of join directions, any of: up down left right - or those combined with another frametype e.g left-heavy down-light" - -boxonly -default 0 -help "-boxonly true restricts results to the corner,vertical and horizontal box elements - It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj" - *values -min 1 -max 1 - frametype -choices "" -choiceprefix 0 -help "name from the predefined frametypes - or an adhoc dictionary." - }] + *id textblock::framedef + *proc -name textblock::framedef\ + -help "Return a dict of the elements that make up a frame border. + May return a subset of available elements based on memberglob values." + + -joins -default "" -type list\ + -help "List of join directions, any of: up down left right + or those combined with another frametype e.g left-heavy down-light." + -boxonly -default 0 -type boolean\ + -help "-boxonly true restricts results to the corner,vertical and horizontal box elements + It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." + + *values -min 1 + frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ + -help "name from the predefined frametypes or an adhoc dictionary." + memberglob -type globstring -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { + corner noncorner top bottom vertical horizontal left right + hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj + }\ + -help "restrict to keys matching memberglob." + }] #append spec \n "frametype -help \"A predefined \"" punk::args::get_dict $spec $args return @@ -5562,7 +6073,8 @@ tcl::namespace::eval textblock { #set targetdown,targetleft,targetright,targetup vars #default empty targets to current box type 'light' foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] + set rawtarget [tcl::dict::get $join_targets $dir] + lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same switch -- $target { "" - light { set target$dir light @@ -5778,6 +6290,46 @@ tcl::namespace::eval textblock { } #four way junction (cd::fwj) (punk::ansi::g0 n) (punk::char::charshort lvhz) (+) } + light_b { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] + tcl::dict::with arcframe {} ;#extract keys as vars + } + light_c { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] + tcl::dict::with arcframe {} ;#extract keys as vars + } "heavy" { #unicode box drawing set set hl [punk::char::charshort boxd_hhz] ;# light horizontal @@ -6010,6 +6562,46 @@ tcl::namespace::eval textblock { } } } + heavy_b { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] + tcl::dict::with arcframe {} ;#extract keys as vars + } + heavy_c { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] + tcl::dict::with arcframe {} ;#extract keys as vars + } "double" { #unicode box drawing set set hl [punk::char::charshort boxd_dhz] ;# double horizontal \U2550 @@ -6184,72 +6776,74 @@ tcl::namespace::eval textblock { #8 #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) + #set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set tlc \U2566 ;# (ttj) + #set blc [punk::char::charshort boxd_huhz] ;# (btj) + set blc \u2569 ;# (btj) #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) + set trc [punk::char::charshort boxd_ddhz] ;# (ttj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) } left_up { #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) + set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_dvl] ;# (rtj) + set blc [punk::char::charshort boxd_duhz] ;# (btj) set hltj \u2569 ;# (btj) set vllj \u2563 ;# (rtj) } right_up { #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) + set tlc [punk::char::charshort boxd_dvr] ;# (ltj) + set trc [punk::char::charshort boxd_dvhz] ;# (fwj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) set hltj \u2569 ;# (btj) set vlrj \u2560 ;# (ltj) } down_left_right { #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_dvhz] ;# (fwj) + set brc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_ddhz] ;# (ttj) + set tlc [punk::char::charshort boxd_ddhz] ;# (ttj) set hlbj \u2566 ;# (ttj) set vlrj \u2560 ;# (ltj) } down_left_up { #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) + set blc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_dvl] ;# (rtj) + set brc [punk::char::charshort boxd_dvl] ;# (rtj) set hltj \u2569 ;# (btj) set hlbj \u2566 ;# (ttj) } down_right_up { #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) + set tlc [punk::char::charshort boxd_dvr] ;# (ltj) + set blc [punk::char::charshort boxd_dvr] ;# (ltj) + set trc [punk::char::charshort boxd_dvhz] ;# (fwj) + set brc [punk::char::charshort boxd_dvhz] ;# (fwj) set hltj \u2569 ;# (btj) set hlbj \u2566 ;# (ttj) } left_right_up { #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) + set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_dvhz] ;# (fwj) + set blc [punk::char::charshort boxd_duhz] ;# (btj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) set hltj \u2569 ;# (btj) } down_left_right_up { #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) + set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) + set blc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_dvhz] ;# (fwj) + set brc [punk::char::charshort boxd_dvhz] ;# (fwj) set hltj \u2569 ;# (btj) set hlbj \u2566 ;# (ttj) } @@ -6358,6 +6952,46 @@ tcl::namespace::eval textblock { } } } + arc_b { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] + tcl::dict::with arcframe {} ;#extract keys as vars + } + arc_c { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] + tcl::dict::with arcframe {} ;#extract keys as vars + } block1 { #box drawing as far as we can go without extra blocks from legacy computing unicode block - which is unfortunately not commonly supported set hlt \u2581 ;# lower one eighth block @@ -6492,8 +7126,6 @@ tcl::namespace::eval textblock { vll $vll vlr $vlr\ blc $blc hlb $hlb brc $brc\ ] - tcl::dict::set framedef_cache $cache_key $result - return $result } else { set result [tcl::dict::create\ tlc $tlc hlt $hlt trc $trc\ @@ -6504,16 +7136,18 @@ tcl::namespace::eval textblock { vllj $vllj\ vlrj $vlrj\ ] - tcl::dict::set framedef_cache $cache_key $result - return $result } + set result [dict filter $result key {*}$globs] + tcl::dict::set framedef_cache $cache_key $result + return $result } + variable frame_cache set frame_cache [tcl::dict::create] proc frame_cache {args} { set argd [punk::args::get_dict { - -action -default "" -choices {clear} -help "Clear the textblock::frame_cache dictionary" + -action -default {} -choices {clear} -help "Clear the textblock::frame_cache dictionary" -pretty -default 1 -help "Use 'pdict textblock::frame_cache */*' for prettier output" *values -min 0 -max 0 } $args] @@ -6590,72 +7224,148 @@ tcl::namespace::eval textblock { -buildcache 1\ -pad 1\ -crm_mode 0\ + -checkargs 1\ ] #-pad 1 is default so that simple 'textblock::frame "[a+ Red]a \nbbb[a]" extends the bg colour on the short ragged lines (and empty lines) # for ansi art - -pad 0 is likely to be preferable - set expect_optval 0 - set argposn 0 - set pmax [expr {[llength $args]-1}] - set has_contents 0 ;#differentiate between empty string and no content supplied - set contents "" - set arglist [list] - foreach a $args { - if {!$expect_optval} { - if {$argposn < $pmax} { - if {[tcl::string::match -* $a]} { - set expect_optval 1 - lappend arglist $a - } else { - error "textblock::frame expects -option pairs" - } - } else { - set has_contents 1 - set contents $a - } + set has_contents 0 + set arglist $args + if {[llength $args] %2 == 0} { + if {[lindex $args end-1] eq "--"} { + set contents [lpop arglist end] + set has_contents 1 + lpop arglist end ;#drop the end-of-opts flag } else { - lappend arglist $a - set expect_optval 0 + set arglist $args + set contents "" } - incr argposn - } - - #set contents [lindex $args end] - #set arglist [lrange $args 0 end-1] - if {[llength $arglist] % 2 != 0} { - error "Usage frame ?-type unicode|altg|ascii|? ?-title ? ?-subtitle ? ?-width ? ?-ansiborder ? ?-boxlimits hl|hlt|hlb|vl|vll|vlr|tlc|blc|brc? ?-joins left|right|up|down? " + } else { + #set arglist [lrange $args 0 end-1] + #set contents [lindex $args end] + set contents [lpop arglist end] + set has_contents 1 } + #todo args -justify left|centre|right (center) - #todo -blockalignbias -textalignbias? #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache + set optnames [tcl::dict::keys $opts] + set opts_ok 1 ;#default assumption foreach {k v} $arglist { - switch -- $k { + set k2 [tcl::prefix::match -error "" $optnames $k] + switch -- $k2 { -etabs - -type - -boxlimits - -boxmap - -joins - -title - -subtitle - -width - -height - -ansiborder - -ansibase - -blockalign - -textalign - -ellipsis - -crm_mode - - -usecache - -buildcache - -pad { - tcl::dict::set opts $k $v + - -usecache - -buildcache - -pad + - -checkargs { + tcl::dict::set opts $k2 $v } default { - error "frame option '$k' not understood. Valid options are [tcl::dict::keys $opts]" + #error "frame option '$k' not understood. Valid options are $optnames" + set opts_ok 0 + break } } } + set check_args [dict get $opts -checkargs] + + #only use punk::args if check_args is true or our basic checks failed + if {!$opts_ok || $check_args} { + #error "Usage frame ?-type unicode|altg|ascii|? ?-title ? ?-subtitle ? ?-width ? ?-ansiborder ? ?-boxlimits hl|hlt|hlb|vl|vll|vlr|tlc|blc|brc? ?-joins left|right|up|down? " + set FRAMETYPES [textblock::frametypes] + set EG [a+ brightblack] + set RST [a] + set argd [punk::args::get_dict [punk::lib::tstr -return string { + *proc -name "textblock::frame"\ + -help "Frame a block of text with a border." + -checkargs -default 1 -type boolean\ + -help "If true do extra argument checks and + provide more comprehensive error info. + Set false for slight performance improvement." + -etabs -default 0\ + -help "expanding tabs - experimental/unimplemented." + -type -default light -choices {${$FRAMETYPES}} -choicerestricted 0 -type dict\ + -help "Type of border for frame." + -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. + passing an empty string will result in no box, but title/subtitle will still appear if supplied. + ${$EG}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${$RST}" + -boxmap -default {} -type dict + -joins -default {} -type list + -title -default "" -type string -regexprefail {\n}\ + -help "Frame title placed on topbar - no newlines. + May contain ANSI - no trailing reset required. + ${$EG}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${$RST}" + -subtitle -default "" -type string -regexprefail {\n}\ + -help "Frame subtitle placed on bottombar - no newlines + May contain Ansi - no trailing reset required." + -width -default "" -type int\ + -help "Width of resulting frame including borders. + If omitted or empty-string, the width will be determined automatically based on content." + -height -default "" -type int\ + -help "Height of resulting frame including borders." + -ansiborder -default "" -type ansistring\ + -help "Ansi escape sequence to set border attributes. + ${$EG}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${$RST}" + -ansibase -default "" -type ansistring\ + -help "Default ANSI attributes within frame." + -blockalign -default centre -choices {left right centre}\ + -help "Alignment of the content block within the frame." + -pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background + extends within the content block inside the frame. + Has no effect if no ANSI in content." + -textalign -default left -choices {left right centre}\ + -help "Alignment of text within the content block. (centre unimplemented)" + -ellipsis -default 1 -type boolean\ + -help "Whether to show elipsis for truncated content and title/subtitle." + -usecache -default 1 -type boolean + -buildcache -default 1 -type boolean + -crm_mode -default 0 -type boolean\ + -help "Show ANSI control characters within frame contents. + (Control Representation Mode) + Frame width doesn't adapt and content may be truncated + so -width may need to be manually set to display more." + + *values -min 0 -max 1 + contents -default "" -type string\ + -help "Frame contents - may be a block of text containing newlines and ANSI. + Text may be 'ragged' - ie unequal line-lengths. + No trailing ANSI reset required. + ${$EG}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${$RST}" + }] $args] + set opts [dict get $argd opts] + set contents [dict get $argd values contents] + } + + # -- --- --- --- --- --- + # cache relevant + set opt_usecache [tcl::dict::get $opts -usecache] + set opt_buildcache [tcl::dict::get $opts -buildcache] + set usecache $opt_usecache ;#may need to override + set opt_etabs [tcl::dict::get $opts -etabs] ;#affects contentwidth - needed before cache determination + set opt_crm_mode [tcl::dict::get $opts -crm_mode] # -- --- --- --- --- --- - set opt_etabs [tcl::dict::get $opts -etabs] set opt_type [tcl::dict::get $opts -type] set opt_boxlimits [tcl::dict::get $opts -boxlimits] set opt_joins [tcl::dict::get $opts -joins] set opt_boxmap [tcl::dict::get $opts -boxmap] - set opt_usecache [tcl::dict::get $opts -usecache] - set opt_buildcache [tcl::dict::get $opts -buildcache] - set opt_pad [tcl::dict::get $opts -pad] - set opt_crm_mode [tcl::dict::get $opts -crm_mode] - set usecache $opt_usecache ;#may need to override set buildcache $opt_buildcache + set opt_pad [tcl::dict::get $opts -pad] + # -- --- --- --- --- --- + set opt_title [tcl::dict::get $opts -title] + set opt_subtitle [tcl::dict::get $opts -subtitle] + set opt_width [tcl::dict::get $opts -width] + set opt_height [tcl::dict::get $opts -height] + # -- --- --- --- --- --- + set opt_ansiborder [tcl::dict::get $opts -ansiborder] + set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_blockalign [tcl::dict::get $opts -blockalign] set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] set known_frametypes $frametypes ;# light, heavey etc as defined in the ::textblock::frametypes variable @@ -6692,6 +7402,7 @@ tcl::namespace::eval textblock { } } } + #review vllj etc? if {!$is_boxlimits_ok} { error "frame option -boxlimits '$opt_boxlimits' must contain only values from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" } @@ -6708,7 +7419,7 @@ tcl::namespace::eval textblock { } } switch -- $target { - "" - light - heavy - ascii - altg - arc - double - custom - block - block1 - block2 {} + "" - light - light_b - light_c - heavy - heavy_b - heavy_c - ascii - altg - arc - arc_b - arc_c - double - custom - block - block1 - block2 {} default { set is_joins_ok 0 break @@ -6719,11 +7430,10 @@ tcl::namespace::eval textblock { error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" } set is_boxmap_ok 1 - #safe jumptable test - #dict for {boxelement subst} $opt_boxmap {} tcl::dict::for {boxelement subst} $opt_boxmap { switch -- $boxelement { hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + hltj - hlbj - vllj - vlrj {} default { set is_boxmap_ok 0 break @@ -6731,7 +7441,7 @@ tcl::namespace::eval textblock { } } if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" } #sorted order down left right up @@ -6756,13 +7466,8 @@ tcl::namespace::eval textblock { set do_joins [::join $join_directions _] - # -- --- --- --- --- --- - set opt_title [tcl::dict::get $opts -title] - set opt_subtitle [tcl::dict::get $opts -subtitle] - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - # -- --- --- --- --- --- - set opt_blockalign [tcl::dict::get $opts -blockalign] + + #JMN switch -- $opt_blockalign { left - right - centre - center {} default { @@ -6778,11 +7483,7 @@ tcl::namespace::eval textblock { error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" } } - # -- --- --- --- --- --- - set opt_ansiborder [tcl::dict::get $opts -ansiborder] - set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental - set opt_ellipsis [tcl::dict::get $opts -ellipsis] # -- --- --- --- --- --- if {$has_contents} { @@ -6793,10 +7494,11 @@ tcl::namespace::eval textblock { set tw 8 } if {$opt_etabs} { + #todo set contents [textutil::tabify::untabify2 $contents $tw] } } - set contents [tcl::string::map [list \r\n \n] $contents] + set contents [tcl::string::map {\r\n \n} $contents] if {$opt_crm_mode} { if {$opt_height eq ""} { set h [textblock::height $contents] @@ -6809,9 +7511,13 @@ tcl::namespace::eval textblock { set w [expr {$opt_width -2}] } set contents [overtype::renderspace -crm_mode 1 -wrap 1 -width $w -height $h "" $contents] + set actual_contentwidth $w + set actual_contentheight $h + } else { + #set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) + #set actual_contentheight [textblock::height $contents] + lassign [textblock::size_as_list $contents] actual_contentwidth actual_contentheight } - set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) - set actual_contentheight [textblock::height $contents] } else { set actual_contentwidth 0 set actual_contentheight 0 @@ -6824,6 +7530,7 @@ tcl::namespace::eval textblock { set titlewith 0 set content_or_title_width $actual_contentwidth } + #opt_subtitle ?? if {$opt_width eq ""} { set frame_inner_width $content_or_title_width @@ -6847,7 +7554,9 @@ tcl::namespace::eval textblock { variable frame_cache #review - custom frame affects frame_inner_width - exclude from caching? #set cache_key [concat $arglist $frame_inner_width $frame_inner_height] - set hashables [concat $arglist $frame_inner_width $frame_inner_height] + #jmn + #set hashables [concat $arglist $frame_inner_width $frame_inner_height] + set hashables [list {*}$arglist $frame_inner_width $frame_inner_height] if {$use_md5} { #package require md5 ;#already required at package load @@ -7207,7 +7916,12 @@ tcl::namespace::eval textblock { } } #set body [textblock::join -- {*}$bodyparts] - set cache_body [textblock::join -- {*}$cache_bodyparts] + + #JMN test + #assert - lhs, cache_inner, rhs non-ragged - so can use join_basic REVIEW + #set cache_body [textblock::join -- {*}$cache_bodyparts] + set cache_body [textblock::join_basic -- {*}$cache_bodyparts] + append fscached $cache_body #append fs $body } @@ -7259,11 +7973,13 @@ tcl::namespace::eval textblock { #review if {[tcl::string::is integer -strict $opt_height] && $actual_contentheight < ($opt_height -2)} { set diff [expr {($opt_height -2) - $actual_contentheight}] - append contents [::join [lrepeat $diff \n] ""] + append contents [::join [lrepeat $diff \n] ""] ;# should not affect actual_contentwidth } + #set cwidth [textblock::width $contents] + set cwidth $actual_contentwidth if {$opt_pad} { - set paddedcontents [textblock::pad $contents -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) + set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) set paddedwidth [textblock::widthtopline $paddedcontents] #review - horizontal truncation if {$paddedwidth > $cache_patternwidth} { @@ -7272,11 +7988,10 @@ tcl::namespace::eval textblock { #important to supply end of opts -- to textblock::join - particularly here with arbitrary data set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays } else { - set cwidth [textblock::width $contents] if {$cwidth > $cache_patternwidth} { set contents [overtype::renderspace -width $cache_patternwidth "" $contents] } - set contentblock [textblock::join -- $contents] + set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line } set tlines [split $template \n] diff --git a/src/modules/#modpod-modpodtest-999999.0a1.0/modpodtest-999999.0a1.0.tm b/src/modules/#modpod-modpodtest-999999.0a1.0/modpodtest-999999.0a1.0.tm index b10d2cb9..7264c625 100644 --- a/src/modules/#modpod-modpodtest-999999.0a1.0/modpodtest-999999.0a1.0.tm +++ b/src/modules/#modpod-modpodtest-999999.0a1.0/modpodtest-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_modpodtest 0 999999.0a1.0] +#[manpage_begin punkshell_module_modpodtest 0 999999.0a1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/argparsingtest-999999.0a1.0.tm b/src/modules/argparsingtest-999999.0a1.0.tm index c76bb4e2..fcd9043c 100644 --- a/src/modules/argparsingtest-999999.0a1.0.tm +++ b/src/modules/argparsingtest-999999.0a1.0.tm @@ -1,16 +1,16 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2024 +# (C) Julian Noble 2024 # # @@ Meta Begin # Application argparsingtest 999999.0a1.0 # Meta platform tcl -# Meta license +# Meta license MIT # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_argparsingtest 0 999999.0a1.0] +#[manpage_begin punkshell_module_argparsingtest 0 999999.0a1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -277,7 +277,7 @@ namespace eval argparsingtest { #punk::args is slower than argp - but comparable, and argp doesn't support solo flags proc test1_punkargs {args} { set argd [punk::args::get_dict { - *proc -name argtest4 -description "test of punk::args::get_dict comparative performance" + *proc -name argtest4 -help "test of punk::args::get_dict comparative performance" *opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -296,7 +296,7 @@ namespace eval argparsingtest { } proc test1_punkargs_validate_without_ansi {args} { set argd [punk::args::get_dict { - *proc -name argtest4 -description "test of punk::args::get_dict comparative performance" + *proc -name argtest4 -help "test of punk::args::get_dict comparative performance" *opts -anyopts 0 -return -default string -type string -choices {string object} -help "return type" -frametype -default \uFFEF -type string diff --git a/src/modules/patternpunk-1.1.tm b/src/modules/patternpunk-1.1.tm index ac1782ba..7d37a2cd 100644 --- a/src/modules/patternpunk-1.1.tm +++ b/src/modules/patternpunk-1.1.tm @@ -13,6 +13,7 @@ package require pattern package require overtype +package require punk::ansi package require punk::lib pattern::init @@ -76,7 +77,7 @@ set ::punk::bannerTemplate [string trim { } else { lassign $cborder_ctext cborder ctext } - return [textblock::frame -type arc -ansiborder [a+ Web-black $cborder] [a+ Web-black $ctext][$this . logo2]] + return [ textblock::frame-type arc -ansiborder [a+ Web-black $cborder] [a+ Web-black $ctext][$this . logo2]] } >punk .. Property logotk "\[TCL\\\n TK \]" proc TCL {args} { @@ -108,6 +109,45 @@ proc TCL {args} { } return $version } +>punk .. Method poses {args} { + set argd [punk::args::get_dict { + *proc -name ">punk . poses" -help "Show or list the poses for the Punk mascot" + -censored -default 1 -type boolean -help "Set true to include mild toilet humour poses" + -return -default table -choices {list table} + } $args] + set censored [dict get $argd opts -censored] + set return [dict get $argd opts -return] + + set poses [list\ + front\ + back\ + lhs\ + left\ + rhs\ + right\ + lhs_air\ + rhs_air\ + lhs_hips\ + rhs_hips\ + lhs_bend\ + rhs_bend\ + lhs_thrust\ + rhs_thrust\ + ] + if {!$censored} { + #allow toilet humour + lappend poses piss poop + } + if {$return eq "list"} { + return $poses + } + set cells [list] + foreach pose $poses { + lappend cells "$pose\n\n[>punk . $pose]" + } + textblock::list_as_table -show_hseps 1 -columns 4 $cells +} + >punk .. Property front [string trim { _|_ @ v @ @@ -266,7 +306,7 @@ _+ +_ _- -_ \ // / \\ - _+_+ + +_+_ } \n] >punk .. Property rhs_thrust [string trim { \\\_ @@ -275,7 +315,7 @@ _+ +_ _- -_ \ \\ / // - _+_+ + +_+_ } \n] >punk .. Property fossil [string trim { @@ -287,6 +327,38 @@ v \\_/ v_ /|\/ / \__/ } \n] +>punk .. Method deck {args} { + #todo - themes? + set this @this@ + set RST [a] + set punk_colour [a+ term-71] ;#term-darkseagreen4-b + set hbar_colour [a+ web-silver] + set vbar_colour [a+ web-steelblue] + set border_colour [a+ web-lightslategray] + set frame_type arc + set punk $punk_colour[$this . lhs_air]$RST + package require punk::args + set standard_frame_types [textblock::frametypes] + set argd [punk::args::get_dict [tstr -return string { + *proc -name "deck" -help "Punk Deck mascot" + -frame -default arc -choices "${$standard_frame_types}" -choicerestricted 0 -choiceprefix 1 + -boxmap -default {} -type dict + -boxlimits -default {hl vl tlc blc trc brc} -help "Limit the border box to listed elements." + -border_colour -default ${$border_colour} -type ansistring -regexprepass {^$} -validationtransform { + -function stripansi -maxlen 0 + } + -title -default "PATTERN" -type string + -subtitle -default "PUNK" -type string + *values -max 0 + }] $args] + set frame_type [dict get $argd opts -frame] + set box_map [dict get $argd opts -boxmap] + set box_limits [dict get $argd opts -boxlimits] + set border_colour [dict get $argd opts -border_colour] + set title [dict get $argd opts -title] + set subtitle [dict get $argd opts -subtitle] + set punkdeck [overtype::right [overtype::left [textblock::frame -ansiborder $border_colour -type $frame_type -boxmap $box_map -boxlimits $box_limits -title $hbar_colour$title$RST -subtitle $hbar_colour$subtitle$RST $punk] "$vbar_colour\n\n\P\nU\nN\nK$RST"] "$vbar_colour\n\nD\nE\nC\nK"] +} >punk .. Method gcross {{size 1} args} { package require textblock textblock::gcross {*}$args $size diff --git a/src/modules/poshinfo-999999.0a1.0.tm b/src/modules/poshinfo-999999.0a1.0.tm index 79e6b2c1..01c71675 100644 --- a/src/modules/poshinfo-999999.0a1.0.tm +++ b/src/modules/poshinfo-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -18,12 +18,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_poshinfo 0 999999.0a1.0] +#[manpage_begin punkshell_module_poshinfo 0 999999.0a1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[titledesc {poshinfo prompt theme tool}] [comment {-- Name section and table of contents description --}] +#[moddesc {POSH-related prompt tool}] [comment {-- Description at end of page heading --}] #[require poshinfo] -#[keywords module] +#[keywords module terminal console theme prompt {prompt theme} POSH] #[description] #[para] - @@ -49,6 +49,7 @@ package require Tcl 8.6- package require punk::config package require json ;#tcllib #toml, yaml? +package require punk::args #*** !doctools #[item] [package {Tcl 8.6}] @@ -71,9 +72,11 @@ package require json ;#tcllib # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #tcl::namespace::eval poshinfo::class { + #*** !doctools #[subsection {Namespace poshinfo::class}] #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { #*** !doctools #[list_begin enumerated] @@ -96,6 +99,7 @@ package require json ;#tcllib #*** !doctools #[list_end] [comment {--- end class enumeration ---}] + #} #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -114,18 +118,6 @@ tcl::namespace::eval poshinfo { - #proc sample1 {p1 n args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 - # #[para] Arguments: - # # [list_begin arguments] - # # [arg_def tring p1] A description of string argument p1. - # # [arg_def integer n] A description of integer argument n. - # # [list_end] - # return "ok" - #} - proc info_from_filename {fname} { #string based filename processing: we are deliberately avoiding test of file existence etc here if {$fname eq ""} { @@ -137,7 +129,12 @@ tcl::namespace::eval poshinfo { } set ftail [file tail $fname] set rootname [file rootname $ftail] - set format [string trimleft [file extension $ftail] .] + set extension [string trimleft [file extension $ftail] .] + if {$extension eq "yml"} { + set format "yaml" + } else { + set format $extension + } set parts [split $rootname .] if {[lindex $parts end] eq "omp"} { set type omp @@ -146,54 +143,122 @@ tcl::namespace::eval poshinfo { if {$rootname eq "schema"} { set type schema } else { + #review - we can't tell diff betw . and .. set type unknown } set shortname $rootname } - return [dict create shortname $shortname format $format type $type] + return [dict create shortname $shortname format $format extension $extension type $type] } - proc themes_dict {{globfor *}} { + #restrict glob to filename in filename.. + proc Themes_dict {{globlist *}} { set running_config [punk::config::get running-config] set posh_themes_path [tcl::dict::get $running_config posh_themes_path] #posh_themes_path_extra ?? - set themes [tcl::dict::create] + set themes_dict [tcl::dict::create] if {[string length $posh_themes_path]} { if {[file exists $posh_themes_path]} { - set files [glob -nocomplain -directory $posh_themes_path -tails $globfor] + set files [glob -nocomplain -directory $posh_themes_path -tails -- {*}$globlist] foreach ftail $files { set themeinfo [info_from_filename $ftail] set shortname [dict get $themeinfo shortname] - dict set themeinfo path [file join $posh_themes_path $ftail] - if {![dict exists $themes $shortname]} { - dict set themes $shortname [list $themeinfo] - } else { - dict lappend themes $shortname $themeinfo + + set name_matched 0 + foreach glob $globlist { + if {[string match -nocase $glob $shortname]} { + set name_matched 1 + break + } + } + if {$name_matched} { + dict set themeinfo path [file join $posh_themes_path $ftail] + if {![dict exists $themes_dict $shortname]} { + dict set themes_dict $shortname [list $themeinfo] + } else { + dict lappend themes_dict $shortname $themeinfo + } } } } } - return $themes + return $themes_dict + } + proc get_active_theme {} { + lassign [punk::config::get running posh_theme] _ themepath + set theme_info [info_from_filename $themepath] + dict set theme_info path $themepath + } + proc set_active_theme_by_name {name} { + error "unimplemented" } - proc themes {{globfor *}} { - set themes [themes_dict $globfor] + proc set_active_theme_by_path {path} { + error "unimplemented" + } + proc themes {args} { + set argd [punk::args::get_dict { + *id poshinfo::themes + *proc -name poshinfo::themes + -format -default all -multiple 1 -choices {all yaml json}\ + -help "File format of posh theme - based on file extension" + -type -default all -multiple 1\ + -help "e.g omp" + -as -default "table" -choices {list showlist dict showdict table tableobject plaintext}\ + -help "return type of result" + *values -min 0 + globs -multiple 1 -default * -help "" + } $args] + set return_as [dict get $argd opts -as] + set formats [dict get $argd opts -format] ;#multiple + if {"yaml" in $formats} { + lappend formats "yml" ;#unpreferred extension for yaml - but accepted + } + set types [dict get $argd opts -type] ;#multiple + set globlist [dict get $argd values globs] + + set themes_dict [Themes_dict $globlist] + set restricted_themes_dict [dict create] + dict for {shortname themeinfolist} $themes_dict { + set themeinfo [lindex $themeinfolist 0] + if {("all" in $formats || [dict get $themeinfo format] in $formats) && ("all" in $types || [dict get $themeinfo type] in $types)} { + dict set restricted_themes_dict $shortname $themeinfolist + } + } + unset themes_dict + switch -- $return_as { + dict { + return $restricted_themes_dict + } + showdict { + return [showdict $restricted_themes_dict */@*/@*.@*] + } + list { + return [dict keys $restricted_themes_dict] + } + showlist { + return [showlist [dict keys $restricted_themes_dict]] + } + } + set posh_theme [file normalize [punk::config::get_running_global posh_theme]] set t [textblock::class::table new "Posh Themes"] $t configure -show_header 1 -show_hseps 0 $t add_column -headers Shortname $t add_column -headers Path - dict for {shortname themeinfolist} $themes { + dict for {shortname themeinfolist} $restricted_themes_dict { #hack - support just one for now set themeinfo [lindex $themeinfolist 0] set path [dict get $themeinfo path] $t add_row [list $shortname $path] + set fg "" set bg "" switch -- [dict get $themeinfo type] { schema { + set fg black set bg Web-orange } omp {} @@ -212,9 +277,22 @@ tcl::namespace::eval poshinfo { $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fg {*}$bg] } } - set result [$t print] - $t destroy - return $result + switch -- $return_as { + plaintext { + $t configure -frametype {} + set tabletext [$t print] + set pt [punk::ansi::ansistrip $tabletext] + return [join [lines_as_list -line trimline $pt] \n] + } + table { + set tabletext [$t print] + $t destroy + return $tabletext + } + tableobject { + return $t + } + } } @@ -230,6 +308,7 @@ tcl::namespace::eval poshinfo { tcl::namespace::eval poshinfo::lib { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase tcl::namespace::path [tcl::namespace::parent] + #*** !doctools #[subsection {Namespace poshinfo::lib}] #[para] Secondary functions that are part of the API @@ -254,7 +333,9 @@ tcl::namespace::eval poshinfo::lib { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Internal] + #tcl::namespace::eval poshinfo::system { + #*** !doctools #[subsection {Namespace poshinfo::system}] #[para] Internal functions that are not part of the API diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 4bd8aae0..59efcc9c 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -7326,21 +7326,28 @@ namespace eval punk { if {$topic in [list tcl]} { - if {[punk::lib::system::has_tclbug_script_var]} { - append warningblock \n "minor warning: punk::lib::system::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" + if {[punk::lib::check::has_tclbug_script_var]} { + append warningblock \n "minor warning: punk::lib::check::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" } - if {[punk::lib::system::has_tclbug_safeinterp_compile]} { + if {[punk::lib::check::has_tclbug_safeinterp_compile]} { set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_safeinterp returned true!" \n + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_safeinterp returned true!" \n append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n - append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/1095bf7f75" + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/1095bf7f75]" append warningblock [a] } - if {[punk::lib::system::has_tclbug_list_quoting_emptyjoin]} { + if {[punk::lib::check::has_tclbug_lsearch_strideallinline]} { set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_list_quoting returned true!" \n + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_lsearch_strideallinline returned true!" \n + append warningblock "${indent}(lsearch using -stride -all -inline -subindices does not return values corresponding to subindex when a single -index value is used)" \n + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/5a1aaa201d]" + append warningblock [a] + } + if {[punk::lib::check::has_tclbug_list_quoting_emptyjoin]} { + set indent " " + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_list_quoting returned true!" \n append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n - append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/e38dce74e2" + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/e38dce74e2]" } } diff --git a/src/modules/punk/aliascore-999999.0a1.0.tm b/src/modules/punk/aliascore-999999.0a1.0.tm index 1019fe4a..aaec24ae 100644 --- a/src/modules/punk/aliascore-999999.0a1.0.tm +++ b/src/modules/punk/aliascore-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,12 +18,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::aliascore 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::aliascore 0 999999.0a1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[titledesc {punkshell command aliases}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::aliascore] -#[keywords module] +#[keywords module alias] #[description] #[para] - diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 0b4db903..27912322 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -417,8 +417,11 @@ tcl::namespace::eval punk::ansi { convert*\ clear*\ cursor_*\ + delete*\ detect*\ + erase*\ get_*\ + hyperlink\ move*\ reset*\ ansistrip*\ @@ -618,7 +621,7 @@ tcl::namespace::eval punk::ansi { set subtitle [tcl::dict::get $picinfo status] } set title [tcl::dict::get $picinfo filename] - set fr [textblock::frame -width $colwidth -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] + set fr [textblock::frame -checkargs 0 -width $colwidth -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] # -- --- --- --- #we need the max height of a row element to use join_basic instead of join below # -- --- --- --- @@ -3096,6 +3099,18 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return "\033\[?25l" } + # REVIEW - osc8 replays etc for split lines? - textblock + #the 'id' parameter logically connects split hyperlinks + proc hyperlink {uri {display ""}} { + if {$display eq ""} { + set display $uri + } + set params "" ;#todo e.g id=xyz123:foo=bar:baz=quux + set open "\x1b\]8\;$params\;$uri\x1b\\" + set close "\x1b\]8\;\;\x1b\\" + return ${open}${display}${close} + } + # -- --- --- --- --- proc move {row col} { #*** !doctools @@ -3634,11 +3649,27 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } set parts [punk::ansi::ta::split_codes $text] set out "" + #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" + # - (if/when lsearch -stride bug fixed) foreach {pt code} $parts { append out $pt } return $out } + proc ansistrip2 {text} { + #*** !doctools + #[call [fun ansistrip] [arg text] ] + #[para]Return a string with ansi codes stripped out + #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) + + if {[punk::ansi::ta::detect_g0 $text]} { + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + } + set parts [punk::ansi::ta::split_codes $text] + #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" + # - (if/when lsearch -stride bug fixed) + join [lmap v [lseq 0 to [llength $parts] by 2] {lindex $parts $v}] "" ;#slightly slower than above foreach + } #interp alias {} stripansi {} ::punk::ansi::ansistrip proc ansistripraw {text} { #*** !doctools @@ -3842,8 +3873,9 @@ tcl::namespace::eval punk::ansi { proc sgr_merge {codelist args} { set allparts [list] foreach c $codelist { - set cparts [punk::ansi::ta::split_codes_single $c] - lappend allparts {*}[lsearch -all -inline -not $cparts ""] + #set cparts [punk::ansi::ta::split_codes_single $c] + #lappend allparts {*}[lsearch -all -inline -not $cparts ""] + lappend allparts {*}[punk::ansi::ta::get_codes_single $c] } sgr_merge_singles $allparts {*}$args } @@ -4362,10 +4394,12 @@ tcl::namespace::eval punk::ansi::ta { # -- --- --- --- variable re_ansi_detect1 "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" # -- --- --- --- - #handrafted TRIE version of above. Somewhat difficult to construct and maintain. TODO - find a regext TRIE generator that works with Tcl regexes + #handrafted TRIE version of above. Somewhat difficult to construct and maintain. TODO - find a regexp TRIE generator that works with Tcl regexes #This does make things quicker - but it's too early to finalise the detect/split regexes (e.g missing \U0090 ) - will need to be redone. - variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} + #variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} + variable re_ansi_detect {(?:\x1b(?:\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\((?:0|B)|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} # -- --- --- --- + #variable re_csi_code {(?:\x1b\[|\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]} @@ -4389,9 +4423,7 @@ tcl::namespace::eval punk::ansi::ta { #can be used on dicts - but will check keys too. keys could also contain ansi and have escapes proc detect_in_list {list} { - detect [join $list " "] - } - proc detect_in_list2 {list} { + #loop is commonly faster than using join. (certain ansi codes triggering list quoting? review) foreach item $list { if {[detect $item]} { return 1 @@ -4399,6 +4431,11 @@ tcl::namespace::eval punk::ansi::ta { } return 0 } + #surprisingly - the ::join operation can be (relatively) slow on lists containing ansi + proc detect_in_list2 {list} { + detect [join $list " "] + } + proc detect_g0 {text} [string map [list [list $re_g0_group]] { regexp $text }] @@ -4580,13 +4617,108 @@ tcl::namespace::eval punk::ansi::ta { #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds) #- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped. - proc split_codes_single {text} { + proc split_codes_single2 {text} { variable re_ansi_split return [_perlish_split $re_ansi_split $text] } + proc split_codes_single3 {text} { + #copy from re_ansi_split + _perlish_split {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} $text + } + proc split_codes_single4 {text} { + if {$text eq ""} { + return {} + } + variable re_ansi_split + set re $re_ansi_split + #variable re_ansi_detect1 + #set re $re_ansi_detect1 + set list [list] + set start 0 + + #set re {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + #while {[regexp -start $start -indices -- {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} $text match]} {} + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + lappend list [tcl::string::range $text $start $matchStart-1] + if {$matchEnd < $matchStart} { + set e $matchStart + incr start + } else { + set e $matchEnd + set start [expr {$matchEnd+1}] + } + lappend list [tcl::string::range $text $matchStart $e] + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + proc split_codes_single {text} { + if {$text eq ""} { + return {} + } + variable re_ansi_split + set next 0 + set b -1 + set list [list] + set coderanges [regexp -indices -all -inline -- $re_ansi_split $text] + foreach cr $coderanges { + lappend list [tcl::string::range $text $next [lindex $cr 0]-1] [tcl::string::range $text [lindex $cr 0] [lindex $cr 1]] + set next [expr {[lindex $cr 1]+1}] + } + lappend list [tcl::string::range $text $next end] + return $list + } + proc get_codes_single {text} { + variable re_ansi_split + regexp -all -inline -- $re_ansi_split $text + } #review - tcl greedy expressions may match multiple in one element proc _perlish_split {re text} { + if {$text eq ""} { + return {} + } + set next 0 + set b -1 + set list [list] + set coderanges [regexp -indices -all -inline -- $re $text] + foreach cr $coderanges { + lappend list [tcl::string::range $text $next [lindex $cr 0]-1] [tcl::string::range $text [lindex $cr 0] [lindex $cr 1]] + set next [expr {[lindex $cr 1]+1}] + } + lappend list [tcl::string::range $text $next end] + return $list + } + proc _perlish_split2 {re text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchStart] + incr start + } else { + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + set start [expr {$matchEnd+1}] + } + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + proc _perlish_split3 {re text} { if {$text eq ""} { return {} } diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 7dd722ce..cf9fd5de 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -256,10 +256,10 @@ tcl::namespace::eval punk::args::class { tcl::namespace::eval punk::args { tcl::namespace::export {[a-z]*} variable argspec_cache - variable argspecs + variable argspec_ids variable id_counter - set argspec_cache [tcl::dict::create] - set argspecs [tcl::dict::create] + set argspec_cache [tcl::dict::create] + set argspec_ids [tcl::dict::create] set id_counter 0 #*** !doctools @@ -296,12 +296,15 @@ tcl::namespace::eval punk::args { return $result } - #todo? -synonym ? (applies to opts only not values) - #e.g -background -synonym -bg -default White + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix e.g -corner -aliases {-corners} + #We mightn't want the prefix to be longer just because of an alias proc Get_argspecs {optionspecs args} { variable argspec_cache - variable argspecs + #variable argspecs ;#REVIEW!! + variable argspec_ids variable initial_optspec_defaults variable initial_valspec_defaults #ideally we would use a fast hash algorithm to produce a short key with low collision probability. @@ -319,31 +322,37 @@ tcl::namespace::eval punk::args { -type string\ -optional 1\ -allow_ansi 1\ - -validate_without_ansi 0\ + -validate_ansistripped 0\ -strip_ansi 0\ -nocase 0\ -choiceprefix 1\ + -choicerestricted 1\ -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ ] set valspec_defaults [tcl::dict::create\ -type string\ -optional 0\ -allow_ansi 1\ - -validate_without_ansi 0\ + -validate_ansistripped 0\ -strip_ansi 0\ -nocase 0\ -choiceprefix 1\ + -choicerestricted 1\ -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ ] - #we need a -choiceprefix default even though it often doesn't apply so we can look it up to display in Help if there are -choices + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices #default to 1 for convenience #checks with no default #-minlen -maxlen -range - #default -allow_ansi to 1 and -validate_without_ansi to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_without_ansi 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist set opt_required [list] set val_required [list] set arg_info [tcl::dict::create] @@ -465,7 +474,7 @@ tcl::namespace::eval punk::args { -anyopts { set opt_any $v } - -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix { + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted { #review - only apply to certain types? tcl::dict::set optspec_defaults $k $v } @@ -488,30 +497,31 @@ tcl::namespace::eval punk::args { dict - dictionary { set v dict } - none - any - ansistring { - - } - list { + none - "" - - - any - ansistring - globstring - list { } default { #todo - disallow unknown types unless prefixed with custom- } } - tcl::dict::set optspec_defaults $k $v + tcl::dict::set optspec_defaults -type $v } -optional - -allow_ansi - - -validate_without_ansi - + -validate_ansistripped - -strip_ansi - + -regexprepass - + -regexprefail - + -validationtransform - -multiple { #allow overriding of defaults for options that occur later tcl::dict::set optspec_defaults $k $v } default { - set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\ + set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -validationtransform\ } error "punk::args::Get_argspecs - unrecognised key '$k' in *opts line. Known keys: $known" } @@ -523,13 +533,19 @@ tcl::namespace::eval punk::args { switch -- $k { -min - -minvalues { + if {$v < 0} { + error "punk::args::Get_argspecs - minimum acceptable value for key '$k' in *opts line is 0. got $v" + } set val_min $v } -max - -maxvalues { + if {$v < -1} { + error "punk::args::Get_argspecs - minimum acceptable value for key '$k' in *opts line is -1 (indicating unlimited). got $v" + } set val_max $v } - -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -nocase { + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set valspec_defaults $k $v } @@ -563,16 +579,20 @@ tcl::namespace::eval punk::args { } -optional - -allow_ansi - - -validate_without_ansi - + -validate_ansistripped - -strip_ansi - + -regexprepass - + -regexprefail - + -validationtransform - -multiple { tcl::dict::set valspec_defaults $k $v } default { set known { -min -minvalues -max -maxvalues\ - -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\ + -minlen -maxlen -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -validationtransform\ } error "punk::args::Get_argspecs - unrecognised key '$k' in *values line. Known keys: $known" } @@ -637,30 +657,59 @@ tcl::namespace::eval punk::args { error "punk::args::get_dict - invalid -type 'none' for positional argument positional argument '$argname'" } } - any - ansistring { + any - anything { tcl::dict::set spec_merged -type any } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } 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] } } } - -default - -solo - -range - -choices - -choiceprefix - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { + -default - -solo - -range - -choices - -choiceprefix - -choicerestricted - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail + { #review -solo 1 vs -type none ? tcl::dict::set spec_merged $spec $specval } + -validationtransform { + #string is dict only 8.7/9+ + if {([llength $specval] % 2) != 0} { + error "punk::args::get_dict - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minlen - -maxlen - -range { + } + default { + set known_transform_keys [list -function -type -minlen -maxlen -range] ;#-choices etc? + error "punk::args::get_dict - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys" + } + } + } + + } default { - set known_argspecs [list -default -type -range -choices -choiceprefix -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help] + set known_argspecs [list -default -type -range -choices -choiceprefix -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -validationtransform\ + ] error "punk::args::get_dict - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" } } } set argspecs $spec_merged if {$is_opt} { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen + set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen } else { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen + set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen } tcl::dict::set arg_info $argname $argspecs tcl::dict::set arg_checks $argname $argchecks @@ -693,8 +742,8 @@ tcl::namespace::eval punk::args { } - set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen - set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen + set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen + set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen set result [tcl::dict::create\ id $spec_id\ @@ -717,30 +766,55 @@ tcl::namespace::eval punk::args { proc_info $proc_info\ ] tcl::dict::set argspec_cache $cache_key $result - tcl::dict::set argspecs $spec_id $optionspecs + #tcl::dict::set argspecs $spec_id $optionspecs + tcl::dict::set argspec_ids $spec_id $optionspecs #puts "xxx:$result" return $result } proc get_spec {id} { - variable argspecs - if {[tcl::dict::exists $argspecs $id]} { - return [tcl::dict::get $argspecs $id] + variable argspec_ids + if {[tcl::dict::exists $argspec_ids $id]} { + return [tcl::dict::get $argspec_ids $id] } return } proc get_spec_ids {{match *}} { - variable argspecs - return [tcl::dict::keys $argspecs $match] + variable argspec_ids + return [tcl::dict::keys $argspec_ids $match] } #for use within get_dict only #This mechanism gets less-than-useful results for oo methods #e.g {$obj} proc Get_caller {} { - set cmdinfo [tcl::dict::get [tcl::info::frame -3] cmd] + set call_level -3 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] #puts "-->$cmdinfo" #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } set caller [regexp -inline {\S+} $cmdinfo] if {$caller eq "namespace"} { set cmdinfo "punk::args::get_dict called from namespace" @@ -748,7 +822,18 @@ tcl::namespace::eval punk::args { return $cmdinfo } + #basic recursion blocker + variable arg_error_isrunning 0 proc arg_error {msg spec_dict {badarg ""}} { + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $badarg" + } + set arg_error_isrunning 1 + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + # use basic colours here to support terminals without extended colours #todo - add checks column (e.g -minlen -maxlen) set errmsg $msg @@ -802,136 +887,120 @@ tcl::namespace::eval punk::args { #set greencheck [a+ web-limegreen]\u2713[a] set greencheck [a+ brightgreen]\u2713[a] - if {![catch {package require punk::trie}]} { - set opt_names_display [list] - set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - set M "\x1b\[32m" ;#mark in green - set RST "\x1b\[m" - foreach c [dict get $spec_dict opt_names] { - set id [dict get $idents $c] - if {$id eq $c} { - lappend opt_names_display $M$c$RST - } else { - set idlen [string length $id] - lappend opt_names_display "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" - } - } - } else { - set opt_names_display [dict get $spec_dict opt_names] - } - - - foreach argshow $opt_names_display arg [dict get $spec_dict opt_names] { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - #set default $c_default[dict get $arginfo -default] - set default [dict get $arginfo -default] - } else { - set default "" - } - set help [::punk::args::Dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - } else { - set casemsg " (case sensitive)" - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - append help "Choices$prefixmsg$casemsg" - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - append help "\n " [join [dict get $arginfo -choices] "\n "] - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - set M "\x1b\[32m" ;#mark in green - set RST "\x1b\[m" - foreach c [dict get $arginfo -choices] { - set id [dict get $idents $c] - if {$id eq $c} { - append help "\n " "$M$c$RST" - } else { - set idlen [string length $id] - append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" - } - } - } errM]} { - puts stderr "prefix marking failed\n$errM" - append help "\n " [join [dict get $arginfo -choices] "\n "] + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict opt_names]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $spec_dict opt_names] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] } - } - } - if {[::punk::args::Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck + lappend opt_names_display $M$prefix$RST$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } } else { - set multiple "" - } - $t add_row [list $argshow [dict get $arginfo -type] $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg + set opt_names [dict get $spec_dict opt_names] + set opt_names_display $opt_names } } - foreach arg [dict get $spec_dict val_names] { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - set default [dict get $arginfo -default] - } else { - set default "" - } - set help [::punk::args::Dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" + set val_names [dict get $spec_dict val_names] + set val_names_display $val_names + + #display options first then values + foreach argumentset [list [list $opt_names_display $opt_names] [list $val_names_display $val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict arg_info $arg] + if {[dict exists $arginfo -default]} { + #set default $c_default[dict get $arginfo -default] + set default [dict get $arginfo -default] } else { - set casemsg " (case sensitive)" + set default "" } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" + set help [::punk::args::Dict_getdef $arginfo -help ""] + if {[dict exists $arginfo -choices]} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + } else { + set casemsg " (case sensitive)" + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set formattedchoices [list] + append help " Choices$prefixmsg$casemsg" + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + set formattedchoices [dict get $arginfo -choices] + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $arginfo -choices] { + set id [dict get $idents $c] + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend formattedchoices "$M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail]" + } + } errM]} { + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + set formattedchoices [dict get $arginfo -choices] + + } + } + set numcols 4 + if {[llength $formattedchoices] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formattedchoices] + } + #risk of recursing + set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices] + append help \n[textblock::join -- " " $choicetable] + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } } - append help "Choices$prefixmsg$casemsg" - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[::punk::args::Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck } else { - if {[catch { - set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - set M "\x1b\[32m" ;#mark in green - set RST "\x1b\[m" - foreach c [dict get $arginfo -choices] { - set id [dict get $idents $c] - if {$id eq $c} { - append help "\n " "$M$c$RST" - } else { - set idlen [string length $id] - append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" - } - } - } errM]} { - puts stderr "prefix marking failed\n$errM" - append help "\n " [join [dict get $arginfo -choices] "\n "] - } + set multiple "" + } + $t add_row [list $argshow [dict get $arginfo -type] $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg } - } - if {[punk::args::Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } - $t add_row [list $arg [dict get $arginfo -type] $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg } } @@ -950,8 +1019,10 @@ tcl::namespace::eval punk::args { } } else { - #todo - something boring + #couldn't load textblock package + #just return the original errmsg without formatting } + set arg_error_isrunning 0 #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. #Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg @@ -962,6 +1033,14 @@ tcl::namespace::eval punk::args { #provide ability to look up and reuse definitions from ids etc # + proc get_dict_by_id {id {arglist ""}} { + set spec [get_spec $id] + if {$spec eq ""} { + error "punk::args::get_dict_by_id - no such id: $id" + } + return [get_dict $spec $arglist] + } + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. #only supports -flag val pairs, not solo options @@ -1054,6 +1133,171 @@ tcl::namespace::eval punk::args { #todo: -minmultiple -maxmultiple ? set opts $opt_defaults + + if {$id ne "jtest"} { + set arglist {} + set values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "arg_info: $arg_info" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + break + } + + if {[tcl::string::match -* $a]} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set values [lrange $rawargs $i+1 end] + } + } else { + #unlimited number of values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set values [lrange $rawargs $i+1 end] + } + break + } else { + set fullopt [tcl::prefix match -error "" $opt_names $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + break + } + + set flagval [lindex $rawargs $i+1] + if {[dict get $arg_info $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + #review - what if user sets first value that happens to match a default? + if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { + #first occurrence of this flag, whilst stored value matches default + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + incr vals_remaining_possible -2 + if {[incr i] > $maxidx} { + arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs $fullopt + } + } else { + #solo + if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $opts $fullopt] == 0} { + #review - what if default at time opt was specified is not zero? we will end up with more items in the list than the number of times the flag was specified + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + incr vals_remaining_possible -1 + } + lappend flagsreceived $fullopt ;#dups ok + } else { + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option + tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $opt_checks_defaults + if {[tcl::dict::get $arg_info $a -type] ne "none"} { + if {[tcl::dict::get $arg_info $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + lappend flagsreceived $a ;#adhoc flag as supplied + if {[incr i] > $maxidx} { + arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $arg_info $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + } + } else { + #set errmsg [tcl::string::map [list %caller% [Get_caller]] $fullopt] + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" + arg_error $errmsg $argspecs $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + break + } + } + } else { + set values $rawargs ;#no -flags detected + set arglist [list] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + } + + + if {$id eq "jtest"} { if {[set eopts [lsearch -exact $rawargs "--"]] >= 0} { lappend flagsreceived -- set values [lrange $rawargs $eopts+1 end] @@ -1233,6 +1477,10 @@ tcl::namespace::eval punk::args { set arglist [list] } } + } + + + set validx 0 set in_multiple "" set valnames_received [list] @@ -1328,7 +1576,7 @@ tcl::namespace::eval punk::args { set thisarg_checks [tcl::dict::get $arg_checks $argname] set is_multiple [tcl::dict::get $thisarg -multiple] set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_without_ansi [tcl::dict::get $thisarg -validate_without_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] set has_default [tcl::dict::exists $thisarg -default] if {$has_default} { @@ -1336,53 +1584,150 @@ tcl::namespace::eval punk::args { } set type [tcl::dict::get $thisarg -type] set has_choices [tcl::dict::exists $thisarg -choices] + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [punk::args::Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + set validationtransform [tcl::dict::get $thisarg -validationtransform] + if {$is_multiple} { set vlist $v } else { set vlist [list $v] } - if {!$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" - } - } - } - if {$is_validate_without_ansi} { - #validate_without_ansi 1 + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 package require punk::ansi set vlist_check [list] foreach e $vlist { lappend vlist_check [punk::ansi::ansistrip $e] } } else { - #validate_without_ansi 0 + #validate_ansistripped 0 set vlist_check $vlist } - set is_default 0 - if {$has_default} { - foreach e_check $vlist_check { - if {$e_check eq $defaultval} { - incr is_default + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + if {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choices [tcl::dict::get $thisarg -choices] + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + set nocase [tcl::dict::get $thisarg -nocase] + if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { + set dname opts + } else { + set dname values_dict + } + set idx 0 ;# + #opts/values_dict $argname membmer 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 { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $choices] + set v_test [tcl::string::tolower $e_check] + } else { + set casemsg " (case sensitive)" + set v_test $e_check + set choices_test $choices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $e eq $defaultval}] + if {!$matches_default} { + if {$choiceprefix} { + set chosen [tcl::prefix::match -error "" $choices_test $v_test] + if {$chosen ne ""} { + set choice_in_list 1 + #can we handle empty string as a choice? It should just work - REVIEW/test + #must use exact in case glob chars present e.g * ? [] (also ansi has square brackets) + set choice [lsearch -exact -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $choice + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $choice + } + } + } else { + set choice_in_list [expr {$v_test in $choices_test}] + } } + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $v_test + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $v_test + } + lappend vlist_validate $e + lappend vlist_check_validate $e_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs $argname + } + } + incr idx } - if {$is_default eq [llength $vlist]} { - set is_default 1 - } else { - #important to set 0 here too e.g if only one element of many matches default - set is_default 0 + #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 + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + if {$e_check ne $defaultval} { + lappend vlist_validate $e + lappend vlist_check_validate $e + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + } } } #puts "argname:$argname v:$v is_default:$is_default" #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. #arguments that are at their default are not subject to type and other checks - if {$is_default == 0} { + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { switch -- $type { any {} list { @@ -1411,9 +1756,66 @@ tcl::namespace::eval punk::args { } } } - string { + 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 e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punk::lib::ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punk::lib::ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + arg_error "Option $argname for [Get_caller] didn't pass regexprefail regex: '$regexprefail' got '$e'" $argspecs $argname + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minlen 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 -minlen 0 -maxlen 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs $argname + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs $argname + } + } + } + } + if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $vlist_check { + foreach e_check $remaining_e_check { #safe jumptable test #dict for {checkopt checkval} $thisarg_checks {} tcl::dict::for {checkopt checkval} $thisarg_checks { @@ -1436,28 +1838,40 @@ tcl::namespace::eval punk::args { } } } - ansistring { - package require ansi - } int { #-range 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 if {[tcl::dict::exists $thisarg -range]} { lassign [tcl::dict::get $thisarg -range] low high - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname - } + if {"$low$high" ne ""} { if {$low eq ""} { - if {$e_check < $low} { - arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs $argname + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname + } + #lowside unspecified - check only high + if {$e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs $argname + } } } elseif {$high eq ""} { - if {$e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs $argname + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname + } + #highside unspecified - check only low + if {$e_check < $low} { + arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs $argname + } } } else { - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs $argname + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs $argname + } } } } @@ -1577,49 +1991,14 @@ tcl::namespace::eval punk::args { } } } - if {$has_choices} { - #todo -choicelabels - set choices [tcl::dict::get $thisarg -choices] - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set nocase [tcl::dict::get $thisarg -nocase] - foreach e $vlist e_check $vlist_check { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $choices] - set v_test [tcl::string::tolower $e_check] - } else { - set casemsg " (case sensitive)" - set v_test $e_check - set choices_test $choices - } - set choice_ok 0 - if {$choiceprefix} { - if {![catch {tcl::prefix::match $choices_test $v_test} chosen]} { - set choice_ok 1 - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice [lsearch -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list - if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { - tcl::dict::set opts $argname $choice - } else { - tcl::dict::set values_dict $argname $choice - } - } - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - set choice_ok [expr {$v_test in $choices_test}] - } - if {!$choice_ok} { - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs $argname - } - } - } + } + if {$is_strip_ansi} { - set stripped_list [lmap e $vlist {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach if {[tcl::dict::get $thisarg -multiple]} { if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { - tcl::dict::set opts $argname $stripped_list + tcl::dict::set opts $argname $stripped_list } else { tcl::dict::set values_dict $argname $stripped_list } diff --git a/src/modules/punk/assertion-999999.0a1.0.tm b/src/modules/punk/assertion-999999.0a1.0.tm index d0d4c250..bdaabf88 100644 --- a/src/modules/punk/assertion-999999.0a1.0.tm +++ b/src/modules/punk/assertion-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::assertion 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::assertion 0 999999.0a1.0] #[copyright "2024"] #[titledesc {assertion alternative to control::assert}] [comment {-- Name section and table of contents description --}] #[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/basictelnet-999999.0a1.0.tm b/src/modules/punk/basictelnet-999999.0a1.0.tm index 64c35956..229e89e1 100644 --- a/src/modules/punk/basictelnet-999999.0a1.0.tm +++ b/src/modules/punk/basictelnet-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,12 +18,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::basictelnet 0 999999.0a1.0] +#[manpage_begin punkshell::basictelnet 0 999999.0a1.0] #[copyright "2024"] #[titledesc {basic telnet client - DKF/Wiki}] [comment {-- Name section and table of contents description --}] #[moddesc {basic telnet client}] [comment {-- Description at end of page heading --}] #[require punk::basictelnet] -#[keywords module] +#[keywords module telnet protocol console terminal] #[description] #[para] see https://wiki.tcl-lang.org/page/Tcl+Telnet @@ -407,7 +407,7 @@ namespace eval punk::basictelnet { set RST "\x1b\[m" set debug_width 80 - set infoframe [textblock::frame -width $debug_width -ansiborder [a+ green bold] -title "[a cyan]Telnet Debug $terminal_type (encoding guess:$encoding_guess)$RST" $info] + set infoframe [textblock::frame -checkargs 0 -width $debug_width -ansiborder [a+ green bold] -title "[a cyan]Telnet Debug $terminal_type (encoding guess:$encoding_guess)$RST" $info] #set w [textblock::width $infoframe] set spacepatch "$RST[textblock::block $debug_width 4 { }]" #puts -nonewline [punk::ansi::cursor_off] diff --git a/src/modules/punk/blockletter-999999.0a1.0.tm b/src/modules/punk/blockletter-999999.0a1.0.tm index e7e08528..6f06aa8a 100644 --- a/src/modules/punk/blockletter-999999.0a1.0.tm +++ b/src/modules/punk/blockletter-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::blockletter 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::blockletter 0 999999.0a1.0] #[copyright "2024"] #[titledesc {punk::blockletter frame-based large lettering test/logo}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -299,10 +299,10 @@ tcl::namespace::eval punk::blockletter::lib { set h_in [expr {$h -2}] if {$w_in > 0 && $h_in > 0} { set inner [textblock::block $w_in $h_in \u00a0] ;#NBSP - textblock::frame -type $f -height $h -width $w -ansiborder [a+ $bd $bg] -ansibase [a+ $bg] $inner + textblock::frame -checkargs 0 -type $f -height $h -width $w -ansiborder [a+ $bd $bg] -ansibase [a+ $bg] $inner } else { #important to use no content arg - as empty string has 'height' of 1 in the textblock context (min height of any string is 1 row in the console) - textblock::frame -type $f -height $h -width $w -ansiborder [a+ $bd $bg] -ansibase [a+ $bg] + textblock::frame -checkargs 0 -type $f -height $h -width $w -ansiborder [a+ $bd $bg] -ansibase [a+ $bg] } } diff --git a/src/modules/punk/cesu-999999.0a1.0.tm b/src/modules/punk/cesu-999999.0a1.0.tm index 527f07a8..7857b480 100644 --- a/src/modules/punk/cesu-999999.0a1.0.tm +++ b/src/modules/punk/cesu-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -19,7 +19,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::cesu 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::cesu 0 999999.0a1.0] #[copyright "2024"] #[titledesc {CESU compatibility ehcoding scheme for utf-16: 8-Bit (CESU-8) ??}] [comment {-- Name section and table of contents description --}] #[moddesc {CESU experimental}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 3970ad28..412b1f7c 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -593,7 +593,13 @@ namespace eval punk::console { if {!$::punk::console::ansi_available} { return "" } - set callid [info cmdcount] ;#info cmdcount is almost as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context + # -- --- + #set callid [info cmdcount] ;#info cmdcount is fast, though not as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context + #clock clicks is approx 2x faster - but can sometimes give duplicates if called sequentially e.g list [clock clicks] [clock clicks] + #Either is suitable here, where subsequent calls will be relatively far apart in time + #speed of call insignificant compared to function + set callid [clock clicks] + # -- --- # upvar ::punk::console::ansi_response_chunk accumulator diff --git a/src/modules/punk/docgen-999999.0a1.0.tm b/src/modules/punk/docgen-999999.0a1.0.tm index a308c4f6..2c49e7a4 100644 --- a/src/modules/punk/docgen-999999.0a1.0.tm +++ b/src/modules/punk/docgen-999999.0a1.0.tm @@ -31,6 +31,7 @@ namespace eval punk::docgen { error "get_doctools_comments file '$fname' not found" } set fd [open $fname r] + chan conf $fd -translation binary set data [read $fd] close $fd if {![string match "*#\**!doctools*" $data]} { diff --git a/src/modules/punk/experiment-999999.0a1.0.tm b/src/modules/punk/experiment-999999.0a1.0.tm index 8b7287db..2cbad152 100644 --- a/src/modules/punk/experiment-999999.0a1.0.tm +++ b/src/modules/punk/experiment-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::experiment 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::experiment 0 999999.0a1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/island-999999.0a1.0.tm b/src/modules/punk/island-999999.0a1.0.tm index 3b498b5e..345778f8 100644 --- a/src/modules/punk/island-999999.0a1.0.tm +++ b/src/modules/punk/island-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -32,7 +32,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::island 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::island 0 999999.0a1.0] #[copyright "2024"] #[titledesc {filesystem islands for safe interps}] [comment {-- Name section and table of contents description --}] #[moddesc {punk::island for safe interps}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index eed4de73..0ca7232d 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -129,7 +129,7 @@ tcl::namespace::eval punk::lib::ensemble { list [tcl::namespace::which namespace] export *] while 1 { - set renamed ${routinens}::${routinetail}_[info cmdcount] + set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] if {[tcl::namespace::which $renamed] eq {}} break } @@ -147,6 +147,89 @@ tcl::namespace::eval punk::lib::ensemble { } } +# some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated +tcl::namespace::eval punk::lib::check { + proc has_tclbug_script_var {} { + + set script {set j [list spud] ; list} + append script \n + uplevel #0 $script + set rep1 [tcl::unsupported::representation $::j] + set script "" + set rep2 [tcl::unsupported::representation $::j] + + set nostring1 [string match "*no string" $rep1] + set nostring2 [string match "*no string" $rep2] + + #we assume it should have no string rep in either case + #Review: check Tcl versions for behaviour/consistency + if {!$nostring2} { + return true + } else { + return false + } + } + proc has_tclbug_lsearch_strideallinline {} { + #bug only occurs with single -index value combined with -stride -all -inline -subindices + #https://core.tcl-lang.org/tcl/tktview/5a1aaa201d + set result [lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *] + return [expr {$result ne "a2"}] + } + + proc has_tclbug_list_quoting_emptyjoin {} { + #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 + set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases + set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" + return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. + } + + proc has_tclbug_safeinterp_compile {{show 0}} { + #ensemble calls within safe interp not compiled + namespace eval [namespace current]::testcompile { + proc ensembletest {} {string index a 0} + } + + set has_bug 0 + + set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] + if {$show} { + puts outer: + puts $bytecode_outer + } + if {![interp issafe]} { + #test of safe subinterp only needed if we aren't already in a safe interp + if {![catch { + interp create x -safe + } errMsg]} { + x eval {proc ensembletest {} {string index a 0}} + set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] + if {$show} { + puts safe: + puts $bytecode_safe + } + interp delete x + #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) + #It's possible the interp we're running in is also not compiling ensembles. + #we could then get a result of 2 - which still indicates a problem + if {[string last "invokeStk" $bytecode_safe] >= 1} { + incr has_bug + } + } else { + #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? + #unlikely - but we should warn + puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" + } + } + + namespace delete [namespace current]::testcompile + + if {[string last "invokeStk" $bytecode_outer] >= 1} { + incr has_bug + } + return $has_bug + } +} + tcl::namespace::eval punk::lib::compat { #*** !doctools #[subsection {Namespace punk::lib::compat}] @@ -185,7 +268,7 @@ tcl::namespace::eval punk::lib::compat { return [lmap v $keep {lindex $v 1}] } #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. - #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 - and even in 8.7 it doesn't seem to allow returning one index of the stridden 'group' + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 if {"::lpop" ne [info commands ::lpop]} { #puts stderr "Warning - no built-in lpop" @@ -651,6 +734,180 @@ namespace eval punk::lib { } } + proc lzip {args} { + switch -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [lzip2lists {*}$args]} + 3 {return [lzip3lists {*}$args]} + 4 {return [lzip4lists {*}$args]} + 5 {return [lzip5lists {*}$args]} + 6 {return [lzip6lists {*}$args]} + 7 {return [lzip7lists {*}$args]} + 8 {return [lzip8lists {*}$args]} + 9 {return [lzip9lists {*}$args]} + 10 {return [lzip10lists {*}$args]} + 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } + default { + if {[llength $args] < 4000} { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } else { + return [lzipn {*}$args] + } + } + } + } + + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + puts "proc punk::lib::lzip${n}lists {$arglist} \{" + puts "$body" + puts "\}" + proc ::punk::lib::lzip${n}lists $arglist $body + } + + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } + + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} + } + + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + + if {[join $cur {}] == {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 + } + return $zip_l + } + #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible + if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { + #-stride either not available - or has bug preventing use of main algorithm below + proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + } else { + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + } + #experiment with equiv of js template literals with ${expression} in templates #e.g tstr {This is the value of x in calling scope ${$x} !} #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} @@ -2696,7 +2953,8 @@ namespace eval punk::lib { lappend opts -block {} } set text [lindex $args end] - tailcall linelist {*}$opts $text + #tailcall linelist {*}$opts $text + return [linelist {*}$opts $text] } #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds proc lines_as_list2 {args} { @@ -2714,9 +2972,8 @@ namespace eval punk::lib { # important for pipeline & match_assign # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace - set linelist_body { - set usage "linelist ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" if {[llength $args] == 0} { error "linelist missing textchunk argument usage:$usage" } @@ -2917,7 +3174,7 @@ namespace eval punk::lib { set replaycodes $RST ;#todo - default? set transformed [list] #shortcircuit common case of no ansi - #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the have backslash escapes due to Tcl list quoting and escaping behaviour. + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) @@ -2940,17 +3197,20 @@ namespace eval punk::lib { foreach ln $linelist { #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable - set ansisplits [punk::ansi::ta::split_codes_single $ln] - if {[llength $ansisplits]<= 1} { + #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + #get_codes_single lists only the codes. no plaintext or empty elements + set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits] == 0} { #plaintext only - no ansi codes in line lappend transformed [string cat $replaycodes $ln $RST] #leave replaycodes as is for next line set nextreplay $replaycodes } else { set tail $RST - set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + set lastcode [lindex $ansisplits end] ;#may or may not be SGR + set lastcodeoffset [expr {[string length $lastcode]-1}] if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { - if {[lindex $ansisplits end] eq ""} { + if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { #last plaintext is empty. So the line is already suffixed with a reset set tail "" set nextreplay $RST @@ -2960,7 +3220,8 @@ namespace eval punk::lib { set tail $RST set nextreplay $RST } - } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #code is at tail (no trailing plaintext) #No tail reset - and no need to examine whole line to determine stack that is in effect set tail $RST set nextreplay $lastcode @@ -2971,7 +3232,7 @@ namespace eval punk::lib { set tail $RST #determine effective replay for line set codestack [list start] - foreach {pt code} $ansisplits { + foreach code $ansisplits { if {[punk::ansi::codetype::is_sgr_reset $code]} { set codestack [list] ;#different from 'start' marked - this means we've had a reset } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { @@ -3043,89 +3304,418 @@ namespace eval punk::lib { #by putting in calls to punk::ansi the user will get appropriate error messages set linelist_body [string map { "package require punk::ansi"} $linelist_body] } - proc linelist {args} $linelist_body - - - interp alias {} errortime {} punk::lib::errortime - proc errortime {script groupsize {iters 2}} { - #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance - set i 0 - set times {} - if {$iters < 2} {set iters 2} - - for {set i 0} {$i < $iters} {incr i} { - set result [uplevel [list time $script $groupsize]] - lappend times [lindex $result 0] - } - - set average 0.0 - set s2 0.0 - - foreach time $times { - set average [expr {$average + double($time)/$iters}] - } - foreach time $times { - set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + set linelist_body_original { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? - set sigma [expr {int(sqrt($s2))}] - set average [expr int($average)] - - return "$average +/- $sigma microseconds per iteration" - } - - #test function to use with show_jump_tables - #todo - check if switch compilation to jump tables differs by Tcl version - proc switch_char_test {c} { - set dec [scan $c %c] - foreach t [list 1 2 3] { - switch -- $c { - x { - return [list $dec x $t] + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v } - y { - return [list $dec y $t] + default { + error "linelist: Unrecognized option '$o' usage:$usage" } - z { - return [list $dec z $t] + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } } } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + } + - #tcl 8.6/8.7 (at least) - #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable - switch -- $c { - a { - return [list $dec a] - } - {"} { - return [list $dec dquote] + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 } - {[} {return [list $dec lb]} - {]} {return [list $dec rb]} - "{" { - return [list $dec lbrace] + trimleft { + set tl_left 1 } - "}" { - return [list $dec rbrace] + trimright { + set tl_right 1 } default { - return [list $dec $c] + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" } - } - - - - } - - #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) - proc show_jump_tables {args} { - #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. - if {[llength $args] == 1} { - set data [tcl::unsupported::disassemble proc [lindex $args 0]] - } elseif {[llength $args] == 2} { - #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits]<= 1} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[lindex $ansisplits end] eq ""} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach {pt code} $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + proc linelist {args} $linelist_body + + + interp alias {} errortime {} punk::lib::errortime + proc errortime {script groupsize {iters 2}} { + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance + set i 0 + set times {} + if {$iters < 2} {set iters 2} + + for {set i 0} {$i < $iters} {incr i} { + set result [uplevel [list time $script $groupsize]] + lappend times [lindex $result 0] + } + + set average 0.0 + set s2 0.0 + + foreach time $times { + set average [expr {$average + double($time)/$iters}] + } + + foreach time $times { + set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + } + + set sigma [expr {int(sqrt($s2))}] + set average [expr int($average)] + + return "$average +/- $sigma microseconds per iteration" + } + + #test function to use with show_jump_tables + #todo - check if switch compilation to jump tables differs by Tcl version + proc switch_char_test {c} { + set dec [scan $c %c] + foreach t [list 1 2 3] { + switch -- $c { + x { + return [list $dec x $t] + } + y { + return [list $dec y $t] + } + z { + return [list $dec z $t] + } + } + } + + #tcl 8.6/8.7 (at least) + #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable + switch -- $c { + a { + return [list $dec a] + } + {"} { + return [list $dec dquote] + } + {[} {return [list $dec lb]} + {]} {return [list $dec rb]} + "{" { + return [list $dec lbrace] + } + "}" { + return [list $dec rbrace] + } + default { + return [list $dec $c] + } + } + + + + } + + #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) + proc show_jump_tables {args} { + #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. + if {[llength $args] == 1} { + set data [tcl::unsupported::disassemble proc [lindex $args 0]] + } elseif {[llength $args] == 2} { + #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. #not sure if this handles more complex hierarchies or mixins etc. lassign $args obj method if {![info object isa object $obj]} { @@ -3316,7 +3906,87 @@ namespace eval punk::lib { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::lib::flatgrid { + namespace export filler_count rows cols col row block + #WARNING - requires lseq and 'lsearch -stride' + #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 + #todo - 8.6 fallback? + + proc filler_count {listlen numcolumns} { + #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error + #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense + expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} + } + proc rows {list numcolumns {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set rows [list] + set i 1 + foreach s [lrange $splits 0 end-1] { + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + incr i + } + return $rows + } + proc cols {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] + } + return $cols + } + proc cols2 {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [col2 $list $numcolumns $colindex $blank] + } + return $cols + } + proc col {list numcolumns colindex {blank NULL}} { + lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * + } + proc col2 {list numcolumns colindex {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set col [list] + foreach s [lrange $splits 0 end-1] { + lappend col [lindex $padded_list $s+$colindex] + } + return $col + } + proc col3 {list numcolumns colindex {blank NULL}} { + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} + } + proc col4 {list numcolumns colindex {blank NULL}} { + #slow + set vars [lrepeat $numcolumns _] + lset vars $colindex v + if {$blank eq ""} { + return [lmap $vars $list {set v}] + } + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} + } + + proc block {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } + proc block2 {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols2 $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } +} @@ -3330,78 +4000,6 @@ tcl::namespace::eval punk::lib::system { #[para] Internal functions that are not part of the API #[list_begin definitions] - proc has_tclbug_script_var {} { - set script {set j [list spud] ; list} - append script \n - uplevel #0 $script - set rep1 [tcl::unsupported::representation $::j] - set script "" - set rep2 [tcl::unsupported::representation $::j] - - set nostring1 [string match "*no string" $rep1] - set nostring2 [string match "*no string" $rep2] - - #we assume it should have no string rep in either case - #Review: check Tcl versions for behaviour/consistency - if {!$nostring2} { - return true - } else { - return false - } - } - - proc has_tclbug_list_quoting_emptyjoin {} { - #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 - set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases - set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" - return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. - } - - proc has_tclbug_safeinterp_compile {{show 0}} { - #ensemble calls within safe interp not compiled - namespace eval [namespace current]::testcompile { - proc ensembletest {} {string index a 0} - } - - set has_bug 0 - - set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] - if {$show} { - puts outer: - puts $bytecode_outer - } - if {![interp issafe]} { - #test of safe subinterp only needed if we aren't already in a safe interp - if {![catch { - interp create x -safe - } errMsg]} { - x eval {proc ensembletest {} {string index a 0}} - set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] - if {$show} { - puts safe: - puts $bytecode_safe - } - interp delete x - #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) - #It's possible the interp we're running in is also not compiling ensembles. - #we could then get a result of 2 - which still indicates a problem - if {[string last "invokeStk" $bytecode_safe] >= 1} { - incr has_bug - } - } else { - #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? - #unlikely - but we should warn - puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" - } - } - - namespace delete [namespace current]::testcompile - - if {[string last "invokeStk" $bytecode_outer] >= 1} { - incr has_bug - } - return $has_bug - } proc mostFactorsBelow {n} { ##*** !doctools diff --git a/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm b/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm index 62c7edfc..7515ba22 100644 --- a/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm @@ -48,6 +48,7 @@ namespace eval punk::mix::commandset::doc { set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man] foreach maybedoomed $oldfiles { set fd [open $maybedoomed r] + chan conf $fd -translation binary set data [read $fd] close $fd if {[string match "*--- punk::docgen overwrites *" $data]} { @@ -170,7 +171,7 @@ namespace eval punk::mix::commandset::doc { -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 *values -min 0 -max -1 - patterns -default {*} -type any -multiple 1 + patterns -default {*.man} -type any -multiple 1 } $args] set opt_individual [tcl::dict::get $argd opts -individual] set patterns [tcl::dict::get $argd values patterns] @@ -190,7 +191,7 @@ namespace eval punk::mix::commandset::doc { set docroot $projectdir/src/doc cd $docroot - if {!$opt_individual && "*" in $patterns} { + if {!$opt_individual && "*.man" in $patterns} { if {[catch { dtplite validate $docroot } errM]} { @@ -251,6 +252,7 @@ namespace eval punk::mix::commandset::doc { append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n foreach fullpath $matched_paths { + puts stdout "do_docgen processing: $fullpath" set doctools [punk::docgen::get_doctools_comments $fullpath] if {$doctools ne ""} { set fname [file tail $fullpath] diff --git a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm index b7da1035..4ab332b4 100644 --- a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm @@ -1,5 +1,5 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev make' or src/make.tcl to update from -buildversion.txt # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -13,19 +13,70 @@ # @@ Meta End +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_scriptwrap 0 999999.0a1.0] +#[copyright "2024"] +#[titledesc {scriptwrap polyglot tool}] [comment {-- Name section and table of contents description --}] +#[moddesc {scriptwrap tool}] [comment {-- Description at end of page heading --}] +#[require punk::mix::commandset::scriptwrap] +#[keywords module commandset launcher scriptwrap] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of scriptwrap +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by poshinfo +#[list_begin itemized] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements ##e.g package require frobz +package require punk::lib +package require punk::args package require punk::mix package require punk::mix::base package require punk::fileline +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::lib}] +#[item] [package {punk::args}] +#[item] [package {punk::mix}] +#[item] [package {punk::base}] +#[item] [package {punk::fileline}] + +#*** !doctools +#[list_end] + +#*** !doctools +#[section API] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + namespace eval punk::mix::commandset::scriptwrap { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::scriptwrap}] + #[para] Core API functions for punk::mix::commandset::scriptwrap + #[list_begin definitions] + namespace export * namespace eval fileline { @@ -1192,22 +1243,33 @@ namespace eval punk::mix::commandset::scriptwrap { return $result } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap ---}] namespace eval lib { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] + #[para] Library API functions for punk::mix::commandset::scriptwrap + #[list_begin definitions] proc get_wrapper_folders {args} { set argd [punk::args::get_dict { #*** !doctools #[call [fun get_wrapper_folders] [arg args] ] - #[para] Return list of dicts representing wrapper folders. keys: basefolder sourceinfo + #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo #[para] Arguments: # [list_begin arguments] # [arg_def string args] name-value pairs -scriptpath # [list_end] - *proc -name get_wrapper_folders + *id punk::mix::commandset::scriptwrap + *proc -name punk::mix::commandset::get_wrapper_folders + *opts -anyopts 0 - -scriptpath -default "" + -scriptpath -default "" -type directory\ + -help "" + #todo -help folder within a punk.templates provided area??? + *values -minvalues 0 -maxvalues 0 } $args] @@ -1377,11 +1439,16 @@ namespace eval punk::mix::commandset::scriptwrap { return [dict create ok $status linecount [llength $lines] data $tags errors $errors] } - + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap::lib ---}] } namespace eval batchlib { - # + #*** !doctools + #[subsection {Namespace punk::mix::commandset::scriptwrap::batchlib}] + #[para] Utility funcions for processing windows .bat files + #[list_begin definitions] + #see also: https://www.dostips.com/forum/viewtopic.php?t=3803 'Rules for label names vs GOTO and CALL # review - we may need different get_callsite_label functions? @@ -1647,23 +1714,13 @@ namespace eval punk::mix::commandset::scriptwrap { #return rawlabel so we can see it as it appears in the data - as opposed to how it is interpreted as a label by cmd.exe return [list labelfound 1 label $label rawlabel $rawlabel] } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap::batchlib ---}] } } - - - - - - - - - - - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::commandset::scriptwrap { @@ -1671,3 +1728,6 @@ package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::com set version 999999.0a1.0 }] return + +#*** !doctools +#[manpage_end] \ No newline at end of file diff --git a/src/modules/punk/nav/fs-999999.0a1.0.tm b/src/modules/punk/nav/fs-999999.0a1.0.tm index d0af87cc..d8a47541 100644 --- a/src/modules/punk/nav/fs-999999.0a1.0.tm +++ b/src/modules/punk/nav/fs-999999.0a1.0.tm @@ -20,10 +20,10 @@ #*** !doctools #[manpage_begin shellspy_module_punk::nav::fs 0 999999.0a1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[titledesc {punk::nav::fs console filesystem navigation}] [comment {-- Name section and table of contents description --}] +#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] #[require punk::nav::fs] -#[keywords module] +#[keywords module filesystem terminal] #[description] #[para] - @@ -936,7 +936,7 @@ tcl::namespace::eval punk::nav::fs { #windows doesn't consider dotfiles as hidden - mac does (?) #we add dotfiles to flaggedhidden list in case there is some other mechanism that has flagged items as hidden if {$::tcl_platform(platform) ne "windows"} { - lappend flaggedhidden {*}[lsearch -all -inline [concat $dirs $files] ".*"] + lappend flaggedhidden {*}[lsearch -all -inline [list {*}$dirs {*}$files] ".*"] #e.g we can have dupes in the case where there are vfs mounted files that appear as dirs #as we will need to do a (nat)sort as a last step - it will be faster to not sort items prematurely #set flaggedhidden [lsort -unique $flaggedhidden] @@ -977,7 +977,8 @@ tcl::namespace::eval punk::nav::fs { # -- --- - foreach nm [concat $dirs $files] { + #jmn + foreach nm [list {*}$dirs {*}$files] { if {[punk::winpath::illegalname_test $nm]} { lappend nonportable $nm } @@ -1272,7 +1273,8 @@ tcl::namespace::eval punk::nav::fs { #set widest1 [punk::pipedata [list {*}$dirs ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] - set widest1 [tcl::mathfunc::max {*}[lmap v [concat $dirs [list ""]] {string length $v}]] + #set widest1 [tcl::mathfunc::max {*}[lmap v [concat $dirs [list ""]] {string length $v}]] + set widest1 [tcl::mathfunc::max {*}[lmap v [list {*}$dirs ""] {string length $v}]] set displaylist [list] set col1 [string repeat " " [expr {$widest1 + 2}]] diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index 51e2c541..7c75d1f7 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -755,7 +755,9 @@ tcl::namespace::eval punk::ns { set seencmds [list] set masked [list] ;# - set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] + #jmn + #set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] + set cmdsets [list {*}$procs {*}$ensembles {*}$ooclasses {*}$ooobjects {*}$ooprivateobjects {*}$ooprivateclasses {*}$native {*}$interps {*}$coroutines {*}$zlibstreams] foreach a $aliases { if {[list c $a] in $elements} { #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo @@ -1691,7 +1693,8 @@ tcl::namespace::eval punk::ns { proc _pkguse_vars {varnames} { while {"pkguse_vars_[incr n]" in $varnames} {} - return [concat $varnames pkguse_vars_$n] + #return [concat $varnames pkguse_vars_$n] + return [list {*}$varnames pkguse_vars_$n] } proc tracehandler_nowrite {args} { error "readonly in use block" diff --git a/src/modules/punk/packagepreference-999999.0a1.0.tm b/src/modules/punk/packagepreference-999999.0a1.0.tm index c51af490..11adeea8 100644 --- a/src/modules/punk/packagepreference-999999.0a1.0.tm +++ b/src/modules/punk/packagepreference-999999.0a1.0.tm @@ -1,5 +1,5 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# 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. @@ -18,12 +18,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::packagepreference 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::packagepreference 0 999999.0a1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] +#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] #[require punk::packagepreference] -#[keywords module] +#[keywords module package] #[description] #[para] - diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index a425946f..b8f0c1dd 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -898,7 +898,7 @@ namespace eval punk::repl::class { append debug \n $mergedinfo append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $new0] before row:$o_cursor_row after row: $result_row before col:$o_cursor_col after col:$result_col" package require textblock - set debug [textblock::frame -buildcache 0 $debug] + set debug [textblock::frame -checkargs 0 -buildcache 0 $debug] catch {punk::console::move_emitblock_return $debug_first_row 1 $debug} # -- --- --- --- --- --- @@ -962,7 +962,7 @@ namespace eval punk::repl::class { set debug "add_chunk$i" append debug \n $mergedinfo append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $p]" - set debug [textblock::frame -buildcache 0 $debug] + set debug [textblock::frame -checkargs 0 -buildcache 0 $debug] #catch {punk::console::move_emitblock_return [expr {$debug_first_row + ($i * 6)}] 1 $debug} set result [dict get $mergedinfo result] @@ -1033,7 +1033,9 @@ namespace eval punk::repl::class { #todo #each newpart needs its grapheme split info to be stored - set o_rendered_lines [concat $o_rendered_lines [lrange $newparts 1 end]] + #jmn + #set o_rendered_lines [concat $o_rendered_lines [lrange $newparts 1 end]] + lappend o_rendered_lines {*}[lrange $newparts 1 end] } method linecount {} { @@ -1565,11 +1567,11 @@ proc punk::repl::console_debugview {editbuf consolewidth args} { } set debug_height [expr {[llength $lines]+2}] ;#framed height } errM]} { - set info [textblock::frame -buildcache 0 -title "[a red]error$RST" $errM] + set info [textblock::frame -checkargs 0 -buildcache 0 -title "[a red]error$RST" $errM] set debug_height [textblock::height $info] } else { #treat as ephemeral (unreusable) frames due to varying width & height - therefore set -buildcache 0 - set info [textblock::frame -buildcache 0 -ansiborder [a+ bold green] -title "[a cyan]debugview_raw$RST" $info] + set info [textblock::frame -checkargs 0 -buildcache 0 -ansiborder [a+ bold green] -title "[a cyan]debugview_raw$RST" $info] } set debug_width [textblock::widthtopline $info] @@ -1604,14 +1606,14 @@ proc punk::repl::console_editbufview {editbuf consolewidth args} { set info [punk::lib::list_as_lines $lines] } } editbuf_error]} { - set info [textblock::frame -buildcache 0 -title "[a red]error[a]" "$editbuf_error\n$::errorInfo"] + set info [textblock::frame -checkargs 0 -buildcache 0 -title "[a red]error[a]" "$editbuf_error\n$::errorInfo"] } else { set title "[a cyan]editbuf [expr {[llength $editbuf_list]-1}] lines [$editbuf linecount][a]" append title "[a+ yellow bold] col:[format %3s [$editbuf cursor_column]] row:[$editbuf cursor_row][a]" set row1 " lastchar:[ansistring VIEW -lf 1 [$editbuf last_char]] lastgrapheme:[ansistring VIEW -lf 1 [$editbuf last_grapheme]]" set row2 " lastansi:[ansistring VIEW -lf 1 [$editbuf last_ansi]]" set info [a+ green bold]$row1\n$row2[a]\n$info - set info [textblock::frame -buildcache 0 -ansiborder [a+ green bold] -title $title $info] + set info [textblock::frame -checkargs 0 -buildcache 0 -ansiborder [a+ green bold] -title $title $info] } set editbuf_width [textblock::widthtopline $info] set spacepatch [textblock::block $editbuf_width 2 " "] @@ -1635,7 +1637,7 @@ proc punk::repl::console_controlnotification {message consolewidth consoleheight set message [lindex $messagelines 0] ;#only allow single line set info "[a+ bold red]$message[a]" set hlt [dict get [textblock::framedef light] hlt] - set box [textblock::frame -boxmap [list tlc $hlt trc $hlt] -title $message -height 1] + set box [textblock::frame -checkargs 0 -boxmap [list tlc $hlt trc $hlt] -title $message -height 1] set notification_width [textblock::widthtopline $info] set box_offset [expr {$consolewidth - $notification_width - $opt_rightmargin}] set row [expr {$consoleheight - $opt_bottommargin}] @@ -2155,7 +2157,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #----------------------------------------- #list/string-rep bug workaround part 2 - #todo - set flag based on punk::lib::system::has_tclbug_script_var + #todo - set flag based on punk::lib::check::has_tclbug_script_var lappend run_command_cache $run_command_string #puts stderr "run_command_string rep: [rep $run_command_string]" if {[llength $run_command_cache] > 2000} { diff --git a/src/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm index 34dbd40d..316f731c 100644 --- a/src/modules/punk/repo-999999.0a1.0.tm +++ b/src/modules/punk/repo-999999.0a1.0.tm @@ -710,7 +710,7 @@ namespace eval punk::repo { lappend col2_values [dict get $summary_dict $f] } set title1 "" - set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_fields] {string length $v}]] + set widest1 [tcl::mathfunc::max {*}[lmap v [list $title1 {*}$col1_fields] {string length $v}]] set col1 [string repeat " " $widest1] set title2 "" set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2_values] {string length $v}]] diff --git a/src/modules/punk/rest-999999.0a1.0.tm b/src/modules/punk/rest-999999.0a1.0.tm index ec369ac3..4e45ed84 100644 --- a/src/modules/punk/rest-999999.0a1.0.tm +++ b/src/modules/punk/rest-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -19,7 +19,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::rest 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::rest 0 999999.0a1.0] #[copyright "2024"] #[titledesc {punk::rest}] [comment {-- Name section and table of contents description --}] #[moddesc {experimental rest}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/sshrun-999999.0a1.0.tm b/src/modules/punk/sshrun-999999.0a1.0.tm index 2735355f..ef3a700f 100644 --- a/src/modules/punk/sshrun-999999.0a1.0.tm +++ b/src/modules/punk/sshrun-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # (C) 2009 Jose F. Nieves @@ -30,7 +30,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::sshrun 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::sshrun 0 999999.0a1.0] #[copyright "2009"] #[titledesc {Tcl procedures to execute tcl scripts in remote hosts}] [comment {-- Name section and table of contents description --}] #[moddesc {punk::sshrun tclssh clone}] [comment {-- Description at end of page heading --}] diff --git a/src/modules/punk/trie-999999.0a1.0.tm b/src/modules/punk/trie-999999.0a1.0.tm index 06d086fc..a70f377a 100644 --- a/src/modules/punk/trie-999999.0a1.0.tm +++ b/src/modules/punk/trie-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::trie 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::trie 0 999999.0a1.0] #[copyright "2010"] #[titledesc {punk::trie API}] [comment {-- Name section and table of contents description --}] #[moddesc {punk::trie}] [comment {-- Description at end of page heading --}] @@ -64,34 +64,34 @@ package require Tcl 8.6- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::trie::class { - #*** !doctools - #[subsection {Namespace punk::trie::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 ---}] - #} -#} +# #tcl::namespace::eval punk::trie::class { +# #*** !doctools +# #[subsection {Namespace punk::trie::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 ---}] +# #} +# #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -114,11 +114,18 @@ tcl::namespace::eval punk::trie { } #namespace path ::punk::trie::log - #[para] class definitions + #*** !doctools + #[subsection {Namespace punk::trie}] + #[para] Core API functions for punk::trie if {[tcl::info::commands [tcl::namespace::current]::trieclass] eq ""} { #*** !doctools #[list_begin enumerated] + oo::class create [tcl::namespace::current]::trieclass { + #*** !doctools + #[enum] CLASS [class trieclass] + #[list_begin definitions] + variable trie id method matches {t what} { @@ -412,9 +419,8 @@ tcl::namespace::eval punk::trie { } set acc {} - - foreach key [dict keys $t] { - lappend acc {*}[my flatten [dict get $t $key] $prefix$key] + dict for {key val} $t { + lappend acc {*}[my flatten $val $prefix$key] } return $acc } @@ -484,8 +490,14 @@ tcl::namespace::eval punk::trie { my insert $a } } + + #*** !doctools + #[list_end] [comment {--- end definitions ---}] } + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + set testlist [list blah x black blacken] proc test1 {} { #JMN @@ -516,14 +528,9 @@ tcl::namespace::eval punk::trie { # #[list_end] [comment {-- end definitions interface_sample1}] # } - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] } - #*** !doctools - #[subsection {Namespace punk::trie}] - #[para] Core API functions for punk::trie - #[list_begin definitions] + @@ -542,8 +549,6 @@ tcl::namespace::eval punk::trie { - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::trie ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/modules/punk/uc-999999.0a1.0.tm b/src/modules/punk/uc-999999.0a1.0.tm index f62ac678..777693a3 100644 --- a/src/modules/punk/uc-999999.0a1.0.tm +++ b/src/modules/punk/uc-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,12 +18,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::uc 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::uc 0 999999.0a1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::uc] -#[keywords module] +#[keywords module unofficial unicode wcswidth] #[description] #[para] - @@ -35022,7 +35022,9 @@ namespace eval punk::uc::lib { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Internal] + namespace eval punk::uc::system { + #*** !doctools #[subsection {Namespace punk::uc::system}] #[para] Internal functions that are not part of the API diff --git a/src/modules/punk/winlnk-999999.0a1.0.tm b/src/modules/punk/winlnk-999999.0a1.0.tm index 5bcd7172..221f364c 100644 --- a/src/modules/punk/winlnk-999999.0a1.0.tm +++ b/src/modules/punk/winlnk-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::winlnk 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::winlnk 0 999999.0a1.0] #[copyright "2024"] #[titledesc {windows shortcut .lnk library}] [comment {-- Name section and table of contents description --}] #[moddesc {punk::winlnk}] [comment {-- Description at end of page heading --}] @@ -34,7 +34,7 @@ #[para] overview of punk::winlnk #[subsection Concepts] #[para] Windows shortcuts are a binary format file with a .lnk extension -#[para] Shell Link (.LNK) Binary File Format is documented in [MS_SHLLINK].pdf published by Microsoft. +#[para] Shell Link (.LNK) Binary File Format is documented in [lb]MS_SHLLINK[rb].pdf published by Microsoft. #[para] Revision 8.0 published 2024-04-23 diff --git a/src/modules/punk/zip-999999.0a1.0.tm b/src/modules/punk/zip-999999.0a1.0.tm index fa9859c5..5e92941d 100644 --- a/src/modules/punk/zip-999999.0a1.0.tm +++ b/src/modules/punk/zip-999999.0a1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -11,7 +11,7 @@ # @@ Meta Begin # Application punk::zip 999999.0a1.0 # Meta platform tcl -# Meta license +# Meta license MIT # @@ Meta End @@ -19,12 +19,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::zip 0 999999.0a1.0] +#[manpage_begin punkshell_module_punk::zip 0 999999.0a1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::zip] -#[keywords module] +#[keywords module zip fileformat] #[description] #[para] - @@ -60,38 +60,6 @@ package require punk::args #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::zip::class { - #*** !doctools - #[subsection {Namespace punk::zip::class}] - #[para] class definitions - #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace @@ -541,37 +509,60 @@ tcl::namespace::eval punk::zip { #todo - doctools - [arg ?globs...?] syntax? #*** !doctools - #[call [fun mkzip] [arg ?options?] [arg filename] ] - #[para] Create a zip archive in 'filename' + #[call [fun mkzip]\ + # [opt "[option -offsettype] [arg offsettype]"]\ + # [opt "[option -return] [arg returntype]"]\ + # [opt "[option -zipkit] [arg 0|1]"]\ + # [opt "[option -runtime] [arg preamble_filename]"]\ + # [opt "[option -comment] [arg zipfilecomment]"]\ + # [opt "[option -directory] [arg dir_to_zip]"]\ + # [opt "[option -base] [arg archive_root]"]\ + # [opt "[option -exclude] [arg globlist]"]\ + # [arg zipfilename]\ + # [arg ?glob...?]] + #[para] Create a zip archive in 'zipfilename' #[para] If a file already exists, an error will be raised. + #[para] Call 'punk::zip::mkzip' with no arguments for usage display. + set argd [punk::args::get_dict { - *proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" + *proc -name punk::zip::mkzip\ + -help "Create a zip archive in 'filename'" *opts - -offsettype -default "archive" -choices {archive file} -help "zip offsets stored relative to start of entire file or relative to start of zip-archive + -offsettype -default "archive" -choices {archive file}\ + -help "zip offsets stored relative to start of entire file or relative to start of zip-archive Only relevant if the created file has a script/runtime prefix. " - -return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive - the option -return pretty is the default and uses the punk::lib pdict/plist system - to return a formatted list for the terminal - " - -zipkit -default 0 -type none -help "whether to add mounting script - mutually exclusive with -runtime option - currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs + -return -default "pretty" -choices {pretty list none}\ + -help "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal " - -runtime -default "" -help "specify a prefix file - e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip - will create a self-extracting zip archive from the subdir/ folder. - Expects runtime with no existing vfs attached (review) + -zipkit -default 0 -type none\ + -help "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs " - -comment -default "" -help "An optional comment for the archive" - -directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" - -base -default "" -help "The new zip archive will be rooted in this directory if provided - it must be a parent of -directory or the same path as -directory" + -runtime -default ""\ + -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review) + " + -comment -default ""\ + -help "An optional comment for the archive" + -directory -default ""\ + -help "The new zip archive will scan for contents within this folder or current directory if not provided." + -base -default ""\ + -help "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory or the same path as -directory" -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + *values -min 1 -max -1 - filename -type file -default "" -help "name of zipfile to create" - globs -default {*} -multiple 1 -help "list of glob patterns to match. - Only directories with matching files will be included in the archive" + filename -type file -default ""\ + -help "name of zipfile to create" + globs -default {*} -multiple 1\ + -help "list of glob patterns to match. + Only directories with matching files will be included in the archive." } $args] set filename [dict get $argd values filename] @@ -733,7 +724,7 @@ tcl::namespace::eval punk::zip { } set cdoffset [tell $zf] set endrec [binary format a4ssssiis PK\05\06 0 0 \ - $count $count [string length $cd] $cdoffset\ + $count $count [string length $cd] [expr {$cdoffset - $dataStartOffset}]\ [string length $opts(-comment)]] append endrec $opts(-comment) puts -nonewline $zf $cd @@ -793,17 +784,6 @@ tcl::namespace::eval punk::zip::lib { -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval punk::zip::system { - #*** !doctools - #[subsection {Namespace punk::zip::system}] - #[para] Internal functions that are not part of the API - - - -#} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::zip [tcl::namespace::eval punk::zip { diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 572ce27e..87340615 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -21,7 +21,7 @@ #[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] #[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] #[require textblock] -#[keywords module utility lib] +#[keywords module ansi text layout colour table frame console terminal] #[description] #[para] Ansi-aware terminal textblock manipulation @@ -180,7 +180,7 @@ tcl::namespace::eval textblock { variable table_edge_parts set table_edge_parts [tcl::dict::create\ topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ + topinner [struct::set intersect $C $tops]\ topright [struct::set intersect $O [concat $tops $rights]]\ topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ middleleft [struct::set intersect $L $lefts]\ @@ -201,22 +201,22 @@ tcl::namespace::eval textblock { #The usual-case of a single header line is the 'onlyleft,onlyinner,onlyright,onlysolo' set. variable header_edge_parts set header_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ + topleft [struct::set intersect $C [list {*}$tops {*}$lefts]]\ + topinner [struct::set intersect $C $tops]\ + topright [struct::set intersect $O [list {*}$tops {*}$rights]]\ + topsolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ middleleft [struct::set intersect $L $lefts]\ middleinner [list]\ middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts]]\ + middlesolo [struct::set intersect $U [list {*}$lefts {*}$rights]]\ + bottomleft [struct::set intersect $L $lefts]\ bottominner [list]\ bottomright [struct::set intersect $U $rights]\ - bottomsolo [struct::set intersect $U [concat $lefts $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts]]\ + bottomsolo [struct::set intersect $U [list {*}$lefts {*}$rights]]\ + onlyleft [struct::set intersect $C [list {*}$tops {*}$lefts]]\ onlyinner [struct::set intersect $C $tops]\ - onlyright [struct::set intersect $O [concat $tops $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $rights]]\ + onlyright [struct::set intersect $O [list {*}$tops {*}$rights]]\ + onlysolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ ] variable table_hseps set table_hseps [tcl::dict::create\ @@ -321,9 +321,17 @@ tcl::namespace::eval textblock { set switch_keys_valid_copts [lrange $switch_keys_valid_copts 0 end-1] oo::class create [tcl::namespace::current]::table [tcl::string::map [list %topt_keys% $topt_keys %topt_switchkeys% $switch_keys_valid_topts %copt_keys% $copt_keys %copt_switchkeys% $switch_keys_valid_copts] { + #*** !doctools #[enum] CLASS [class textblock::class::table] #[list_begin definitions] + #[para] Create a table suitable for terminal output with various border styles. + #[para] The table can contain multiline cells and ANSI colour and text style attributes. + #[para] Multiple header rows can be configured. + #[para] Header rows can span columns - data rows cannot. + #[para] The restriction on data rows is to maintain compatibility of the data with a Tcl matrix command + #[para] (see get_matrix command) + #[para] Both header and data cells can have various text and blockalignments configured. # [para] [emph METHODS] variable o_opts_table ;#options as configured by user (with exception of -ansireset) variable o_opts_table_effective; #options in effect - e.g with defaults merged in. @@ -348,6 +356,8 @@ tcl::namespace::eval textblock { constructor {args} { #*** !doctools #[call class::table [method constructor] [arg args]] + #[para] TODO - document the many options + set o_opts_table_defaults $::textblock::class::opts_table_defaults set o_opts_column_defaults $::textblock::class::opts_column_defaults @@ -452,6 +462,22 @@ tcl::namespace::eval textblock { set ft_body light } } + light_b { + if {$requested_ft_header eq ""} { + set ft_header heavy_b + } + if {$requested_ft_body eq ""} { + set ft_body light_b + } + } + light_c { + if {$requested_ft_header eq ""} { + set ft_header heavy_c + } + if {$requested_ft_body eq ""} { + set ft_body light_c + } + } default { if {$requested_ft_header eq ""} { set ft_header $requested_ft @@ -525,6 +551,10 @@ tcl::namespace::eval textblock { return [tcl::dict::create body $blims header $hlims] } method configure args { + #*** !doctools + #[call class::table [method configure] [arg args]] + #[para] get or set various table-level properties + if {![llength $args]} { return $o_opts_table } @@ -744,6 +774,11 @@ tcl::namespace::eval textblock { #integrate with struct::matrix - allows ::m format 2string $table method printmatrix {matrix} { + #*** !doctools + #[call class::table [method printmatrix] [arg matrix]] + #[para] clear all table rows and print a matrix into the table + #[para] The rowxcolumn structure must match + set matrix_rowcount [$matrix rows] set matrix_colcount [$matrix columns] set table_colcount [my column_count] @@ -765,6 +800,10 @@ tcl::namespace::eval textblock { my print } method as_matrix {{cmd ""}} { + #*** !doctools + #[call class::table [method as_matrix] [arg ?cmd?]] + #[para] return a struct::matrix command representing the data portion of the table. + if {$cmd eq ""} { set m [struct::matrix] } else { @@ -832,9 +871,16 @@ tcl::namespace::eval textblock { return $colcount } method column_count {} { + #*** !doctools + #[call class::table [method column_count]] + #[para] return the number of columns return [tcl::dict::size $o_columndefs] } method configure_column {index_expression args} { + #*** !doctools + #[call class::table [method configure_column] [arg index_expression] [arg args]] + #[para] - undocumented + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" @@ -1055,6 +1101,9 @@ tcl::namespace::eval textblock { } method header_count {} { + #*** !doctools + #[call class::table [method header_count]] + #[para] return the number of header rows return [tcl::dict::size $o_headerstates] } method header_count_calc {} { @@ -1066,6 +1115,10 @@ tcl::namespace::eval textblock { return $max_headers } method header_height {header_index} { + #*** !doctools + #[call class::table [method header_height] [arg header_index]] + #[para] return the height of a header as the number of content-lines + set idx [lindex [tcl::dict::keys $o_headerstates $header_index]] return [tcl::dict::get $o_headerstates $idx maxheightseen] } @@ -1097,6 +1150,10 @@ tcl::namespace::eval textblock { # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} # method header_colspans {} { + #*** !doctools + #[call class::table [method header_colspans]] + #[para] Show the colspans configured for all headers + #set num_headers [my header_count_calc] set num_headers [my header_count] set colspans_by_header [tcl::dict::create] @@ -1177,6 +1234,10 @@ tcl::namespace::eval textblock { #should be configure_headerrow ? method configure_header {index_expression args} { + #*** !doctools + #[call class::table [method configure_header]] + #[para] - undocumented + #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis #e.g o_headerstates: 0 {maxheightseen 1} 1 {maxheightseen 2} @@ -1448,7 +1509,12 @@ tcl::namespace::eval textblock { method add_row {valuelist args} { #*** !doctools - #[call class::table [method add_row] [arg args]] + #[call class::table [method add_row]\ + # [arg valuelist]\ + # [opt "[option -minheight] [arg int_minheight]"]\ + # [opt "[option -maxheight] [arg int_maxheight]"]\ + # [opt "[option -ansibase] [arg ansicode]"]\ + #] if {[tcl::dict::size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [tcl::dict::size $o_columndefs])} { set msg "" append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [tcl::dict::size $o_columndefs]" \n @@ -1523,16 +1589,15 @@ tcl::namespace::eval textblock { set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] tcl::dict::lappend o_columndata $c $v - set valheight [textblock::height $v] + lassign [textblock::size_as_list $v] valwidth valheight if {$valheight > $max_height_seen} { set max_height_seen $valheight } - set width [textblock::width $v] - if {$width > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { - tcl::dict::set o_columnstates $c maxwidthbodyseen $width + if {$valwidth > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { + tcl::dict::set o_columnstates $c maxwidthbodyseen $valwidth } - if {$width < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { - tcl::dict::set o_columnstates $c minwidthbodyseen $width + if {$valwidth < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { + tcl::dict::set o_columnstates $c minwidthbodyseen $valwidth } if {[tcl::dict::get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [tcl::dict::get $o_columnstates $c minwidthbodyseen] < $prev_minwidth} { @@ -1552,6 +1617,13 @@ tcl::namespace::eval textblock { return $rowcount } method configure_row {index_expression args} { + #*** !doctools + #[call class::table [method configure_row]\ + # [arg index_expression]\ + # [opt "[option -minheight] [arg int_minheight]"]\ + # [opt "[option -maxheight] [arg int_maxheight]"]\ + # [opt "[option -ansibase] [arg ansicode]"]\ + #] set ridx [lindex [tcl::dict::keys $o_rowdefs] $index_expression] if {$ridx eq ""} { error "textblock::table::configure_row - no row defined at index '$ridx'.Use add_row to define rows" @@ -1640,9 +1712,16 @@ tcl::namespace::eval textblock { tcl::dict::set o_rowdefs $ridx $opts } method row_count {} { + #*** !doctools + #[call class::table [method row_count]] + #[para] return the number of data rows in the table. return [tcl::dict::size $o_rowdefs] } method row_clear {} { + #*** !doctools + #[call class::table [method row_clear]] + #[para] Remove all rows without resetting column data. + #[para] When adding new rows the number of entries will need to match the existing column count. set o_rowdefs [tcl::dict::create] set o_rowstates [tcl::dict::create] #The data values are stored by column regardless of whether added row by row @@ -1655,6 +1734,12 @@ tcl::namespace::eval textblock { set o_calculated_column_widths [list] } method clear {} { + #*** !doctools + #[call class::table [method clear]] + #[para] Remove all row and column data. + #[para] If a subsequent call to add_row is made it can contain any number of values. + #[para] Further calls to add_row will need to contain the same number of values + #[para] as the first call unless default values have been set for the missing columns (review - in flux). my row_clear set o_columndefs [tcl::dict::create] set o_columndata [tcl::dict::create] @@ -2000,7 +2085,7 @@ tcl::namespace::eval textblock { #just write an empty vertical placeholder. The spanned value will be overtyped below set cellcontents [::join [lrepeat [llength [split $hval \n]] ""] \n] } - set header_cell_startspan [textblock::frame -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ + set header_cell_startspan [textblock::frame -checkargs 0 -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ -ansibase $ansibase_header -ansiborder $ansiborder_final\ -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ ] @@ -2134,7 +2219,7 @@ tcl::namespace::eval textblock { #set spacemap [list hl * vl * tlc * blc * trc * brc *] #-usecache 1 ok #hval is not raw headerval - it has been padded to required width and has ansi applied - set hblock [textblock::frame -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase + set hblock [textblock::frame -checkargs 0 -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase #puts "==>boxlimits:'$hlims' hval_width:[tcl::string::length $hval] blockwidth:[textblock::width $hblock]" #puts $hblock #puts "==>hval:'$hval'[a]" @@ -2199,7 +2284,7 @@ tcl::namespace::eval textblock { # -usecache 1 ok #frame borders will never display - so use the simplest frametype and don't apply any ansi #puts "===>zerospan hlims: $hlims" - set header_frame [textblock::frame -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ + set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ ] } @@ -2220,7 +2305,7 @@ tcl::namespace::eval textblock { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts only$opt_posn] ] } set header_joins $header_body_joins - set header_frame [textblock::frame -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ + set header_frame [textblock::frame -checkargs 0 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ -ansibase $ansibase_header -ansiborder $ansiborder_final\ -boxlimits $hlims -boxmap $hdrmap -joins $header_joins\ ] @@ -2366,7 +2451,7 @@ tcl::namespace::eval textblock { set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] } } - set rowframe [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] + set rowframe [textblock::frame -checkargs 0 -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] set return_bodywidth [textblock::widthtopline $rowframe] ;#frame lines always same width - just look at top line append part_body $rowframe \n } else { @@ -2384,7 +2469,7 @@ tcl::namespace::eval textblock { set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] } } - append part_body [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n + append part_body [textblock::frame -checkargs 0 -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n } incr r } @@ -2411,7 +2496,7 @@ tcl::namespace::eval textblock { append part_body [tcl::string::repeat " " $colwidth] \n set return_bodywidth $colwidth } else { - set emptyframe [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] + set emptyframe [textblock::frame -checkargs 0 -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] append part_body $emptyframe \n set return_bodywidth [textblock::width $emptyframe] } @@ -2441,6 +2526,10 @@ tcl::namespace::eval textblock { } method get_column_cells_by_index {index_expression} { + #*** !doctools + #[call class::table [method get_column_cells_by_index] [arg index_expression]] + #[para] Return a dict with keys 'headers' and 'cells' giving column header and data values + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { set range "" @@ -2499,7 +2588,9 @@ tcl::namespace::eval textblock { set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] set hval_lines [split $hdr \n] - set hval_lines [concat $hval_lines $hcell_lines] + #jmn concat + #set hval_lines [concat $hval_lines $hcell_lines] + set hval_lines [list {*}$hval_lines {*}$hcell_lines] set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top set hval_block [::join $hval_lines \n] set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] @@ -2556,12 +2647,14 @@ tcl::namespace::eval textblock { set cval_lines [split $cval \n] - set cval_lines [concat $cval_lines $cell_lines] + #jmn + #set cval_lines [concat $cval_lines $cell_lines] + lappend cval_lines {*}$cell_lines set cval_lines [lrange $cval_lines 0 $rowh-1] set cval_block [::join $cval_lines \n] - - set cell [textblock::pad $cval_block -width $datawidth -padchar " " -within_ansi 1 -which $pad] + #//JMN assert widest cval_line = datawidth = known_blockwidth + set cell [textblock::pad $cval_block -known_blockwidth $datawidth -width $datawidth -padchar " " -within_ansi 1 -which $pad] #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] tcl::dict::lappend output cells $cell @@ -2570,6 +2663,10 @@ tcl::namespace::eval textblock { return $output } method get_column_values_by_index {index_expression} { + #*** !doctools + #[call class::table [method get_column_values_by_index] [arg index_expression]] + #[para] List the cell values of a column from the data area only (no header values) + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { return @@ -2577,6 +2674,10 @@ tcl::namespace::eval textblock { return [tcl::dict::get $o_columndata $cidx] } method debug {args} { + #*** !doctools + #[call class::table [method debug]] + #[para] display lots of debug information about how the table is constructed. + #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) set defaults [tcl::dict::create\ -usetables 1\ @@ -2759,12 +2860,20 @@ tcl::namespace::eval textblock { } method column_width {index_expression} { + #*** !doctools + #[call class::table [method column_width] [arg index_expression]] + #[para] inner width of column ie the available cell-width without borders/separators + if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { my calculate_column_widths -algorithm $o_column_width_algorithm } return [lindex $o_calculated_column_widths $index_expression] } method column_widths {} { + #*** !doctools + #[call class::table [method column_width]] + #[para] ordered list of column widths (inner widths) + if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { my calculate_column_widths -algorithm $o_column_width_algorithm } @@ -2774,7 +2883,12 @@ tcl::namespace::eval textblock { #width of a table includes borders and seps #whereas width of a column refers to the borderless width (inner width) method width {} { - #calculate width based on assumption frame verticals are 1-wide - review - what about custom unicode double-wide frame? + #*** !doctools + #[call class::table [method width]] + #[para] width of the table including borders and separators + #[para] calculate width based on assumption frame verticals are 1 screen-column wide + #[para] (review - consider possibility of custom unicode double-wide frame?) + set colwidths [my column_widths] set contentwidth [tcl::mathop::+ {*}$colwidths] set twidth $contentwidth @@ -3284,6 +3398,11 @@ tcl::namespace::eval textblock { #spangroups keyed by column method spangroups {} { + #*** !doctools + #[call class::table [method spangroups]] + #[para] return a dict keyed by column-index showing advanced span information + #[para] (debug tool) + set column_count [tcl::dict::size $o_columndefs] set spangroups [tcl::dict::create] set headerwidths [tcl::dict::create] ;#key on col,hrow @@ -3655,6 +3774,10 @@ tcl::namespace::eval textblock { #print headers and body using different join mechanisms # using -startcolumn to do slightly less work method print {args} { + #*** !doctools + #[call class::table [method print]] + #[para] Return the table as text suitable for console display + if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] } else { @@ -3775,6 +3898,14 @@ tcl::namespace::eval textblock { } } method print_bodymatrix {} { + #*** !doctools + #[call class::table [method print_bodymatrix]] + #[para] output the matrix string corresponding to the body data using the matrix 2string format + #[para] this will be a table without borders,headers,title etc and will exclude additional ANSI applied due to table, row or column settings. + #[para] If the original cell data itself contains ANSI - the output will still contain those ansi codes. + # + + set m [my as_matrix] $m format 2string } @@ -3793,6 +3924,14 @@ tcl::namespace::eval textblock { #Note: A textblock does not necessarily have lines the same length - either in number of characters or print-width # tcl::namespace::eval textblock { + variable frametypes + set frametypes [list light light_b light_c heavy heavy_b heavy_c arc arc_b arc_c double block block1 block2 block2hack ascii altg] + #class::table needs to be able to determine valid frametypes + proc frametypes {} { + variable frametypes + return $frametypes + } + tcl::namespace::eval cd { #todo - save and restore existing tcl::namespace::export in case macros::cd has default exports in future tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export *} @@ -4020,7 +4159,7 @@ tcl::namespace::eval textblock { if {[dict get $opts -frame]} { #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - set output [textblock::frame -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] } else { set output [$t print] } @@ -4030,50 +4169,52 @@ tcl::namespace::eval textblock { return $t } - proc list_as_table {args} { - set argd [punk::args::get_dict [string map [list $::textblock::frametypes] { - -return -default table -choices {table tableobject} - -frametype -default "" -help "frame type: or dict for custom frame" - -show_edge -default "" -type boolean -help "show outer border of table" - -show_seps -default "" -type boolean - -show_vseps -default "" -type boolean -help "Show vertical table separators" - -show_hseps -default "" -type boolean -help "Show horizontal table separators + set FRAMETYPES [textblock::frametypes] + punk::args::Get_argspecs [punk::lib::tstr -return string { + *id textblock::list_as_table + + -return -default table -choices {table tableobject} + -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ + -help "frame type or dict for custom frame" + -show_edge -default "" -type boolean\ + -help "show outer border of table" + -show_seps -default "" -type boolean + -show_vseps -default "" -type boolean\ + -help "Show vertical table separators" + -show_hseps -default "" -type boolean\ + -help "Show horizontal table separators (default 0 if no existing -table supplied)" - -table -default "" -type string -help "existing table object to use" - -colheaders -default "" -type list -help "list of lists. list of column header values. Outer list must match number of columns" - -header -default "" -type list -multiple 1 -help "Headers left to right" - -show_header -default "" -help "Whether to show a header row. - Leave as empty string for unspecified/automatic, - in which case it will display only if -headers list was supplied." - -action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied + -table -default "" -type string\ + -help "existing table object to use" + -colheaders -default "" -type list\ + -help "list of lists. list of column header values. Outer list must match number of columns" + -header -default "" -type list -multiple 1\ + -help "Each supplied -header argument is a header row. + The number of values for each must be <= number of columns" + -show_header -default ""\ + -help "Whether to show a header row. + Leave as empty string for unspecified/automatic, + in which case it will display only if -headers list was supplied." + -action -default "append" -choices {append replace}\ + -help "row insertion method if existing -table is supplied if append is chosen the new values will always start at the first column" - -columns -default "" -type integer -help "Number of table columns + -columns -default "" -type integer\ + -help "Number of table columns Will default to 2 if not using an existing -table object" - *values -min 0 -max 1 - datalist -default {} -help "flat list of table cell values which will be wrapped based on -columns value" - }] $args] + + *values -min 0 -max 1 + datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value" + }] + + proc list_as_table {args} { + set FRAMETYPES [textblock::frametypes] + set argd [punk::args::get_dict_by_id textblock::list_as_table $args] + set opts [dict get $argd opts] set datalist [dict get $argd values datalist] set existing_table [dict get $opts -table] set opt_columns [dict get $opts -columns] - #set opts [tcl::dict::create\ - # -return string\ - # -frametype \uFFEF\ - # -show_edge \uFFEF\ - # -show_seps \uFFEF\ - #] - #foreach {k v} $args { - # switch -- $k { - # -return - -show_edge - -show_seps - -frametype { - # tcl::dict::set opts $k $v - # } - # default { - # error "unrecognised option '$k'. Known options [tcl::dict::keys $opts]" - # } - # } - #} - set count [llength $datalist] set is_new_table 0 @@ -4167,15 +4308,12 @@ tcl::namespace::eval textblock { } } #defaults for new table only - if {[tcl::dict::get $opts -frametype] eq ""} { - tcl::dict::set opts -frametype "light" - } + #if {[tcl::dict::get $opts -show_seps] eq ""} { + # tcl::dict::set opts -show_seps 1 + #} if {[tcl::dict::get $opts -show_edge] eq ""} { tcl::dict::set opts -show_edge 1 } - if {[tcl::dict::get $opts -show_seps] eq ""} { - tcl::dict::set opts -show_seps 1 - } if {[tcl::dict::get $opts -show_vseps] eq ""} { tcl::dict::set opts -show_vseps 1 } @@ -4224,7 +4362,8 @@ tcl::namespace::eval textblock { foreach row $rowdata { set shortfall [expr {$cols - [llength $row]}] if {$shortfall > 0} { - set row [concat $row [lrepeat $shortfall ""]] + #set row [concat $row [lrepeat $shortfall ""]] + lappend row {*}[lrepeat $shortfall ""] } $t add_row $row } @@ -4307,7 +4446,7 @@ tcl::namespace::eval textblock { - set chars [concat [punk::lib::range 1 9] A B C D E F] + set chars [list {*}[punk::lib::range 1 9] A B C D E F] set charsubset [lrange $chars 0 $size-1] if {"noreset" in $colour} { set RST "" @@ -4386,6 +4525,37 @@ tcl::namespace::eval textblock { } return [punk::char::ansifreestring_width $textblock] } + #gather info about whether ragged (samewidth each line = false) and min width + proc widthinfo {textblock} { + #backspaces, vertical tabs ? + if {$textblock eq ""} { + return [dict create width 0 minwidth 0 ragged 0] + } + #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review + if {[tcl::string::last \t $textblock] >= 0} { + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set textblock [textutil::tabify::untabify2 $textblock $tw] + } + if {[punk::ansi::ta::detect $textblock]} { + #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + #return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + set widths [lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}] + set max [tcl::mathfunc::max {*}$widths] + set min [tcl::mathfunc::min {*}$widths] + set ragged [expr {$min != $max}] + return [dict create width $max minwidth $min ragged $ragged] + } + #single line + set w [punk::char::ansifreestring_width $textblock] + return [dict create width $w minwidth $w ragged 0] + } #when we know the block is uniform in width - just examine topline proc widthtopline {textblock} { set firstnl [tcl::string::first \n $textblock] @@ -4489,17 +4659,22 @@ tcl::namespace::eval textblock { set opts [tcl::dict::create\ -padchar " "\ -which "right"\ + -known_blockwidth ""\ + -known_samewidth ""\ + -known_hasansi ""\ -width ""\ -overflow 0\ -within_ansi 0\ ] + #known_samewidth of empty string means we don't know either way, 0 is definitely 'ragged', 1 is definitely homogenous + #review!? #-within_ansi means after a leading ansi code when doing left pad on all but last line #-within_ansi means before a trailing ansi code when doing right pad on all but last line - set usage "pad ?-padchar |? ?-which right|left|centre? ?-width auto|? ?-within_ansi 1|0?" + set usage "pad ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" foreach {k v} $args { switch -- $k { - -padchar - -which - -width - -overflow - -within_ansi { + -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { tcl::dict::set opts $k $v } default { @@ -4551,11 +4726,38 @@ tcl::namespace::eval textblock { } } # -- --- --- --- --- --- --- --- --- --- - - set datawidth [textblock::width $block] + set known_blockwidth [tcl::dict::get $opts -known_blockwidth] + set known_samewidth [tcl::dict::get $opts -known_samewidth] ;# if true - we have a known non-ragged block, if false - could be either. + set datawidth "" if {$width eq "auto"} { - set width $datawidth + #for auto - we + if {$known_blockwidth eq ""} { + if {$known_samewidth ne "" && $known_samewidth} { + set datawidth [textblock::widthtopline $block] + } else { + #set datawidth [textblock::width $block] + set widthinfo [textblock::widthinfo $block] + set known_samewidth [expr {![dict get $widthinfo ragged]}] ;#review - a false value here is definite, distinguished from unknown which would be empty string - so we can take advantage of it + set datawidth [dict get $widthinfo width] + } + } else { + set datawidth $known_blockwidth + } + set width $datawidth ;# this is the width we want to pad out to + #assert datawidth has been set to widest line, taking ansi & 2wide chars into account + } else { + #only call width functions if known_samewidth - otherwise let the pad algorithm below determine it as we go + if {$known_samewidth ne "" && $known_samewidth} { + if {$known_blockwidth eq ""} { + set datawidth [textblock::widthtopline $block + } else { + set datawidth $known_blockwidth + } + } + #assert datawidth may still be empty string } + #assertion + #we can now use the states of datawidth and known_samewidth to determine if algorithm below should calculate widths as it goes. set lines [list] @@ -4578,39 +4780,45 @@ tcl::namespace::eval textblock { #review - tcl format can only pad with zeros or spaces? #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - if 0 { - #review - surprisingly, this doesn't seem to be a performance win - #No detectable diff on small blocks - slightly worse on large blocks - if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { - #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position - #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. - set block [tcl::string::map [list \r\n \n] $block] - if {$which eq "l"} { - set fmt "%+${padchar}*s" - } else { - set fmt "%-${padchar}*s" - } - foreach ln [split $block \n] { - #set lnwidth [punk::char::ansifreestring_width $ln] - set lnwidth [punk::char::grapheme_width_cached $ln] - set lnlen [tcl::string::length $ln] - set diff [expr $lnwidth - $lnlen] - #we need trickwidth to get format to pad a string with a different terminal width compared to string length - set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) - lappend lines [format $fmt $trickwidth $ln] - } - return [::join $lines \n] - } - } + #review - surprisingly, this doesn't seem to be a performance win + #No detectable diff on small blocks - slightly worse on large blocks + # if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { + # #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position + # #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. + # set block [tcl::string::map [list \r\n \n] $block] + # if {$which eq "l"} { + # set fmt "%+${padchar}*s" + # } else { + # set fmt "%-${padchar}*s" + # } + # foreach ln [split $block \n] { + # #set lnwidth [punk::char::ansifreestring_width $ln] + # set lnwidth [punk::char::grapheme_width_cached $ln] + # set lnlen [tcl::string::length $ln] + # set diff [expr $lnwidth - $lnlen] + # #we need trickwidth to get format to pad a string with a different terminal width compared to string length + # set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) + # lappend lines [format $fmt $trickwidth $ln] + # } + # return [::join $lines \n] + # } #todo? special case trailing double-reset - insert between resets? set lnum 0 - if {[punk::ansi::ta::detect $block]} { + + set known_hasansi [tcl::dict::get $opts -known_hasansi] + if {$known_hasansi eq ""} { + set block_has_ansi [punk::ansi::ta::detect $block] + } else { + set block_has_ansi $known_hasansi + } + if {$block_has_ansi} { set parts [punk::ansi::ta::split_codes $block] } else { #single plaintext part set parts [list $block] } + set line_chunks [list] set line_len 0 set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad @@ -4628,10 +4836,16 @@ tcl::namespace::eval textblock { foreach pl $partlines { lappend line_chunks $pl #incr line_len [punk::char::ansifreestring_width $pl] - incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + } if {$p != $last} { #do padding - set missing [expr {$width - $line_len}] + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + set missing [expr {$width - $line_len}] + } else { + set missing [expr {$width - $datawidth}] + } if {$missing > 0} { #commonly in a block - many lines will have the same pad - cache based on missing @@ -4702,7 +4916,11 @@ tcl::namespace::eval textblock { } } #pad last line - set missing [expr {$width - $line_len}] + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + set missing [expr {$width - $line_len}] + } else { + set missing [expr {$width - $datawidth}] + } if {$missing > 0} { if {[tcl::dict::exists $pad_cache $missing]} { set pad [tcl::dict::get $pad_cache $missing] @@ -4788,12 +5006,12 @@ tcl::namespace::eval textblock { proc pad_test {block} { set width [textblock::width $block] set padtowidth [expr {$width + 10}] - set left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - set left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - set left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - set right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - set right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - set right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] + set left0 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 0] + set left1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 1] + set left2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 2] + set right0 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 0] + set right1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 1] + set right2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 2] set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] @@ -4997,6 +5215,50 @@ tcl::namespace::eval textblock { # -- is a legimate block #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) + if {![llength $blocks]} { + return + } + set rowcount 0 + set blocklists [list] + foreach b $blocks { + if {[punk::ansi::ta::detect $b]} { + #-ansireplays 1 quite expensive e.g 7ms in 2024 + set bl [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] + } else { + set bl [split $b \n] + } + if {[llength $bl] > $rowcount} { + set rowcount [llength $bl] + } + lappend blocklists $bl + } + set outlines [list] + for {set r 0} {$r < $rowcount} {incr r} { + set row "" + for {set c 0} {$c < [llength $blocks]} {incr c} { + append row [lindex $blocklists $c $r] + } + lappend outlines $row + } + return [::join $outlines \n] + } + proc ::textblock::join_basic2 {args} { + #*proc -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. + # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner + #" + set argd [punk::args::get_dict { + -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" + -ansiresets -type any -default auto + blocks -type any -multiple 1 + } $args] + set ansiresets [tcl::dict::get $argd opts -ansiresets] + set blocks [tcl::dict::get $argd values blocks] + + #-ansireplays is always on (if ansi detected) + + # -- is a legimate block + #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) + if {![llength $blocks]} { return } @@ -5068,6 +5330,188 @@ tcl::namespace::eval textblock { return } + set idx 0 + set blocklists [list] + set rowcount 0 + foreach b $blocks { + #we need the width of a rendered block for per-row renderline calls or padding + #we may as well use widthinfo to also determine raggedness state to pass on to pad function + #set bwidth [width $b] + set widthinfo [widthinfo $b] + set bwidth [dict get $widthinfo width] + set is_samewidth [expr {![dict get $widthinfo ragged]}] + + #set c($idx) [tcl::string::repeat " " [set w($idx)]] + #fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n- + #for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi. + #testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway. + + #blocks passed to join can be ragged - so we can't pass -known_samewidth to pad + if {[punk::ansi::ta::detect $b]} { + # - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?) + set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n] + set bl [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] + } else { + #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi + set bl [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] + } + set rowcount [expr {max($rowcount,[llength $bl])}] + lappend blocklists $bl + set width($idx) $bwidth + incr idx + } + + set outlines [list] + for {set r 0} {$r < $rowcount} {incr r} { + set row "" + for {set c 0} {$c < [llength $blocklists]} {incr c} { + set cell [lindex $blocklists $c $r] + if {$cell eq ""} { + set cell [string repeat " " $width($c)] + } + append row $cell + } + lappend outlines $row + } + return [::join $outlines \n] + } + + proc ::textblock::join2 {args} { + #set argd [punk::args::get_dict { + # blocks -type string -multiple 1 + #} $args] + #set opts [tcl::dict::get $argd opts] + #set blocks [tcl::dict::get $argd values blocks] + + #-ansireplays is always on (if ansi detected) + + #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets + #textblock::join is already somewhat expensive - we don't want to do much argument processing + #also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation + #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) + set ansiresets auto + switch -- [lindex $args 0] { + -- { + set blocks [lrange $args 1 end] + } + -ansiresets { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory." + } + } + default { + if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} { + error "first flag must be -ansiresets or end of opts marker --" + } else { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory" + } + } + } + } + + if {![llength $blocks]} { + return + } + + set idx 0 + set fordata [list] + set colindices [list] + foreach b $blocks { + set w($idx) [width $b] ;#we need the width of a rendered block for per-row renderline calls or padding + #set c($idx) [tcl::string::repeat " " [set w($idx)]] + #fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n- + #for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi. + #testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway. + if {[punk::ansi::ta::detect $b]} { + #lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] + + # - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?) + set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n] + lappend fordata "v($idx)" [split [textblock::pad $replay_block -known_hasansi 1 -known_blockwidth $w($idx) -width $w($idx) -which right -padchar " "] \n] + } else { + #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi + #lappend fordata "v($idx)" [split $b \n] + lappend fordata "v($idx)" [split [textblock::pad $b -known_hasansi 0 -known_blockwidth $w($idx) -width $w($idx) -which right -padchar " "] \n] + } + lappend colindices $idx + incr idx + } + + + + + set outlines [list] + #set colindices [lsort -integer -increasing [array names c]] + foreach {*}$fordata { + set row "" + foreach colidx $colindices { + #we know we have a single line, no ansi in underlay and no overflow required - so we can use renderline directly + #append row [overtype::renderline -width $w($colidx) -insert_mode 0 -info 0 $c($colidx) $v($colidx)] + #append row [textblock::pad $v($colidx) -width $w($colidx) -which right -padchar " "] + + #short blocks need to have empty lines padded too + if {$v($colidx) eq ""} { + append row [string repeat " " $w($colidx)] + } else { + append row $v($colidx) + } + } + lappend outlines $row + } + return [::join $outlines \n] + } + # This calls textblock::pad per cell :/ + proc ::textblock::join3 {args} { + #set argd [punk::args::get_dict { + # blocks -type string -multiple 1 + #} $args] + #set opts [tcl::dict::get $argd opts] + #set blocks [tcl::dict::get $argd values blocks] + + #-ansireplays is always on (if ansi detected) + + #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets + #textblock::join is already somewhat expensive - we don't want to do much argument processing + #also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation + #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) + set ansiresets auto + switch -- [lindex $args 0] { + -- { + set blocks [lrange $args 1 end] + } + -ansiresets { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory." + } + } + default { + if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} { + error "first flag must be -ansiresets or end of opts marker --" + } else { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory" + } + } + } + } + + if {![llength $blocks]} { + return + } + set idx 0 set fordata [list] set colindices [list] @@ -5097,6 +5541,7 @@ tcl::namespace::eval textblock { } lappend outlines $row } + #puts stderr "--->outlines len: [llength $outlines]" return [::join $outlines \n] } @@ -5122,7 +5567,7 @@ tcl::namespace::eval textblock { set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] set testblock [textblock::testblock 15 rainbow] set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] - set framed [textblock::frame -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] + set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] } @@ -5163,13 +5608,13 @@ tcl::namespace::eval textblock { append out $punks \n append out $cpunks \n append out [textblock::join -- $punks $cpunks] \n - set 2frames_a [textblock::join -- [textblock::frame $cpunks] [textblock::frame $punks]] + set 2frames_a [textblock::join -- [textblock::frame -checkargs 0 $cpunks] [textblock::frame -checkargs 0 $punks]] append out $2frames_a \n - set 2frames_b [textblock::join -- [textblock::frame -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -ansiborder $greenb -title "fancypunks" $cpunks]] - append out [textblock::frame -title "punks" $2frames_b\n$RST$2frames_a] \n - set fancy [overtype::right [overtype::left [textblock::frame -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nL\nI\nF\nE"] + set 2frames_b [textblock::join -- [textblock::frame -checkargs 0 -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -checkargs 0 -ansiborder $greenb -title "fancypunks" $cpunks]] + append out [textblock::frame -checkargs 0 -title "punks" $2frames_b\n$RST$2frames_a] \n + set punkdeck [overtype::right [overtype::left [textblock::frame -checkargs 0 -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nD\nE\nC\nK"] set spantable [[spantest] print] - append out [textblock::join -- $fancy " " $spantable] \n + append out [textblock::join -- $punkdeck " " $spantable] \n #append out [textblock::frame -title gr $gr0] append out [textblock::periodic -forcecolour $opt_forcecolour] return $out @@ -5242,17 +5687,10 @@ tcl::namespace::eval textblock { } } - variable frametypes - set frametypes [list light heavy arc double block block1 block2 block2hack ascii altg] - #class::table needs to be able to determine valid frametypes - proc frametypes {} { - variable frametypes - return $frametypes - } proc frametype {f} { #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] switch -- $f { - light - heavy - arc - double - block - block1 - block2 - block2hack - ascii - altg { + light - light_b - light_c - heavy - heavy_b - heavy_c - arc - arc_b - arc_c - double - block - block1 - block2 - block2hack - ascii - altg { return [tcl::dict::create category predefined type $f] } default { @@ -5262,6 +5700,9 @@ tcl::namespace::eval textblock { foreach {k v} $f { switch -- $k { hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + hltj - hlbj - vllj - vlrj { + #also allow extra join arguments + } default { #k not in custom_keys set is_custom_dict_ok 0 @@ -5295,8 +5736,6 @@ tcl::namespace::eval textblock { return [tcl::dict::get $framedef_cache $cache_key] } - set argopts [lrange $args 0 end-1] - set f [lindex $args end] #here we avoid the punk::args usage on the happy path, even though punk::args is fairly fast, in favour of an even faster literal switch on the happy path #this means we have some duplication in where our flags/opts are defined: here in opts, and in spec below to give nicer error output without affecting performance. @@ -5306,29 +5745,101 @@ tcl::namespace::eval textblock { -boxonly 0\ ] set bad_option 0 - foreach {k v} $argopts { - switch -- $k { + set values [list] + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + set a2 [tcl::prefix match -error "" {-- -joins -boxonly} $a] + switch -- $a2 { -joins - -boxonly { - tcl::dict::set opts $k $v + tcl::dict::set opts $a2 [lindex $args [incr i]] + } + -- { + set values [lrange $args $i+1 end] + break } default { - set bad_option + if {[string match -* $a]} { + set bad_option 1 + } else { + set values [lrange $args $i end] + } break } } } - if {[llength $args] % 2 == 0 || $bad_option} { + set f [lindex $values 0] + set rawglobs [lrange $values 1 end] + if {![llength $rawglobs]} { + set globs * + } else { + set globs [list] + foreach g $rawglobs { + switch -- $g { + hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - + hltj - hlbj - vllj - vlrj { + lappend globs $g + } + corner - corners { + lappend globs tlc blc trc brc + } + noncorner - noncorners { + #same as verticals + horizontals + lappend globs hl* vl* + } + vertical - verticals { + #we don't consider the corners part of this + lappend globs vl* + } + horizontal - horizontals { + lappend globs hl* + } + top - tops { + lappend globs tlc trc hlt* + } + bottom - bottoms { + lappend globs blc brc hlb* + } + left - lefts - lhs { + lappend globs tlc blc vll* + } + right - rights - rhs { + lappend globs trc brc vlr* + } + default { + #must look like a glob search if not one of the above + if {[regexp {[*?\[\]]} $g]} { + lappend globs $g + } else { + set bad_option 1 + } + } + } + } + } + if {$bad_option || [llength $values] == 0} { #no framedef supplied, or unrecognised opt seen set spec [string map [list $::textblock::frametypes] { - *proc -name textblock::framedef - -joins -default "" -help "List of join directions, any of: up down left right - or those combined with another frametype e.g left-heavy down-light" - -boxonly -default 0 -help "-boxonly true restricts results to the corner,vertical and horizontal box elements - It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj" - *values -min 1 -max 1 - frametype -choices "" -choiceprefix 0 -help "name from the predefined frametypes - or an adhoc dictionary." - }] + *id textblock::framedef + *proc -name textblock::framedef\ + -help "Return a dict of the elements that make up a frame border. + May return a subset of available elements based on memberglob values." + + -joins -default "" -type list\ + -help "List of join directions, any of: up down left right + or those combined with another frametype e.g left-heavy down-light." + -boxonly -default 0 -type boolean\ + -help "-boxonly true restricts results to the corner,vertical and horizontal box elements + It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." + + *values -min 1 + frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ + -help "name from the predefined frametypes or an adhoc dictionary." + memberglob -type globstring -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { + corner noncorner top bottom vertical horizontal left right + hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj + }\ + -help "restrict to keys matching memberglob." + }] #append spec \n "frametype -help \"A predefined \"" punk::args::get_dict $spec $args return @@ -5562,7 +6073,8 @@ tcl::namespace::eval textblock { #set targetdown,targetleft,targetright,targetup vars #default empty targets to current box type 'light' foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] + set rawtarget [tcl::dict::get $join_targets $dir] + lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same switch -- $target { "" - light { set target$dir light @@ -5778,6 +6290,46 @@ tcl::namespace::eval textblock { } #four way junction (cd::fwj) (punk::ansi::g0 n) (punk::char::charshort lvhz) (+) } + light_b { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] + tcl::dict::with arcframe {} ;#extract keys as vars + } + light_c { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] + tcl::dict::with arcframe {} ;#extract keys as vars + } "heavy" { #unicode box drawing set set hl [punk::char::charshort boxd_hhz] ;# light horizontal @@ -6010,6 +6562,46 @@ tcl::namespace::eval textblock { } } } + heavy_b { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] + tcl::dict::with arcframe {} ;#extract keys as vars + } + heavy_c { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] + tcl::dict::with arcframe {} ;#extract keys as vars + } "double" { #unicode box drawing set set hl [punk::char::charshort boxd_dhz] ;# double horizontal \U2550 @@ -6184,72 +6776,74 @@ tcl::namespace::eval textblock { #8 #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) + #set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set tlc \U2566 ;# (ttj) + #set blc [punk::char::charshort boxd_huhz] ;# (btj) + set blc \u2569 ;# (btj) #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) + set trc [punk::char::charshort boxd_ddhz] ;# (ttj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) } left_up { #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) + set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_dvl] ;# (rtj) + set blc [punk::char::charshort boxd_duhz] ;# (btj) set hltj \u2569 ;# (btj) set vllj \u2563 ;# (rtj) } right_up { #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) + set tlc [punk::char::charshort boxd_dvr] ;# (ltj) + set trc [punk::char::charshort boxd_dvhz] ;# (fwj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) set hltj \u2569 ;# (btj) set vlrj \u2560 ;# (ltj) } down_left_right { #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_dvhz] ;# (fwj) + set brc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_ddhz] ;# (ttj) + set tlc [punk::char::charshort boxd_ddhz] ;# (ttj) set hlbj \u2566 ;# (ttj) set vlrj \u2560 ;# (ltj) } down_left_up { #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) + set blc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_dvl] ;# (rtj) + set brc [punk::char::charshort boxd_dvl] ;# (rtj) set hltj \u2569 ;# (btj) set hlbj \u2566 ;# (ttj) } down_right_up { #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) + set tlc [punk::char::charshort boxd_dvr] ;# (ltj) + set blc [punk::char::charshort boxd_dvr] ;# (ltj) + set trc [punk::char::charshort boxd_dvhz] ;# (fwj) + set brc [punk::char::charshort boxd_dvhz] ;# (fwj) set hltj \u2569 ;# (btj) set hlbj \u2566 ;# (ttj) } left_right_up { #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) + set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_dvhz] ;# (fwj) + set blc [punk::char::charshort boxd_duhz] ;# (btj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) set hltj \u2569 ;# (btj) } down_left_right_up { #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) + set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) + set blc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_dvhz] ;# (fwj) + set brc [punk::char::charshort boxd_dvhz] ;# (fwj) set hltj \u2569 ;# (btj) set hlbj \u2566 ;# (ttj) } @@ -6358,6 +6952,46 @@ tcl::namespace::eval textblock { } } } + arc_b { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] + tcl::dict::with arcframe {} ;#extract keys as vars + } + arc_c { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] + tcl::dict::with arcframe {} ;#extract keys as vars + } block1 { #box drawing as far as we can go without extra blocks from legacy computing unicode block - which is unfortunately not commonly supported set hlt \u2581 ;# lower one eighth block @@ -6492,8 +7126,6 @@ tcl::namespace::eval textblock { vll $vll vlr $vlr\ blc $blc hlb $hlb brc $brc\ ] - tcl::dict::set framedef_cache $cache_key $result - return $result } else { set result [tcl::dict::create\ tlc $tlc hlt $hlt trc $trc\ @@ -6504,16 +7136,18 @@ tcl::namespace::eval textblock { vllj $vllj\ vlrj $vlrj\ ] - tcl::dict::set framedef_cache $cache_key $result - return $result } + set result [dict filter $result key {*}$globs] + tcl::dict::set framedef_cache $cache_key $result + return $result } + variable frame_cache set frame_cache [tcl::dict::create] proc frame_cache {args} { set argd [punk::args::get_dict { - -action -default "" -choices {clear} -help "Clear the textblock::frame_cache dictionary" + -action -default {} -choices {clear} -help "Clear the textblock::frame_cache dictionary" -pretty -default 1 -help "Use 'pdict textblock::frame_cache */*' for prettier output" *values -min 0 -max 0 } $args] @@ -6590,72 +7224,148 @@ tcl::namespace::eval textblock { -buildcache 1\ -pad 1\ -crm_mode 0\ + -checkargs 1\ ] #-pad 1 is default so that simple 'textblock::frame "[a+ Red]a \nbbb[a]" extends the bg colour on the short ragged lines (and empty lines) # for ansi art - -pad 0 is likely to be preferable - set expect_optval 0 - set argposn 0 - set pmax [expr {[llength $args]-1}] - set has_contents 0 ;#differentiate between empty string and no content supplied - set contents "" - set arglist [list] - foreach a $args { - if {!$expect_optval} { - if {$argposn < $pmax} { - if {[tcl::string::match -* $a]} { - set expect_optval 1 - lappend arglist $a - } else { - error "textblock::frame expects -option pairs" - } - } else { - set has_contents 1 - set contents $a - } + set has_contents 0 + set arglist $args + if {[llength $args] %2 == 0} { + if {[lindex $args end-1] eq "--"} { + set contents [lpop arglist end] + set has_contents 1 + lpop arglist end ;#drop the end-of-opts flag } else { - lappend arglist $a - set expect_optval 0 + set arglist $args + set contents "" } - incr argposn - } - - #set contents [lindex $args end] - #set arglist [lrange $args 0 end-1] - if {[llength $arglist] % 2 != 0} { - error "Usage frame ?-type unicode|altg|ascii|? ?-title ? ?-subtitle ? ?-width ? ?-ansiborder ? ?-boxlimits hl|hlt|hlb|vl|vll|vlr|tlc|blc|brc? ?-joins left|right|up|down? " + } else { + #set arglist [lrange $args 0 end-1] + #set contents [lindex $args end] + set contents [lpop arglist end] + set has_contents 1 } + #todo args -justify left|centre|right (center) - #todo -blockalignbias -textalignbias? #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache + set optnames [tcl::dict::keys $opts] + set opts_ok 1 ;#default assumption foreach {k v} $arglist { - switch -- $k { + set k2 [tcl::prefix::match -error "" $optnames $k] + switch -- $k2 { -etabs - -type - -boxlimits - -boxmap - -joins - -title - -subtitle - -width - -height - -ansiborder - -ansibase - -blockalign - -textalign - -ellipsis - -crm_mode - - -usecache - -buildcache - -pad { - tcl::dict::set opts $k $v + - -usecache - -buildcache - -pad + - -checkargs { + tcl::dict::set opts $k2 $v } default { - error "frame option '$k' not understood. Valid options are [tcl::dict::keys $opts]" + #error "frame option '$k' not understood. Valid options are $optnames" + set opts_ok 0 + break } } } + set check_args [dict get $opts -checkargs] + + #only use punk::args if check_args is true or our basic checks failed + if {!$opts_ok || $check_args} { + #error "Usage frame ?-type unicode|altg|ascii|? ?-title ? ?-subtitle ? ?-width ? ?-ansiborder ? ?-boxlimits hl|hlt|hlb|vl|vll|vlr|tlc|blc|brc? ?-joins left|right|up|down? " + set FRAMETYPES [textblock::frametypes] + set EG [a+ brightblack] + set RST [a] + set argd [punk::args::get_dict [punk::lib::tstr -return string { + *proc -name "textblock::frame"\ + -help "Frame a block of text with a border." + -checkargs -default 1 -type boolean\ + -help "If true do extra argument checks and + provide more comprehensive error info. + Set false for slight performance improvement." + -etabs -default 0\ + -help "expanding tabs - experimental/unimplemented." + -type -default light -choices {${$FRAMETYPES}} -choicerestricted 0 -type dict\ + -help "Type of border for frame." + -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. + passing an empty string will result in no box, but title/subtitle will still appear if supplied. + ${$EG}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${$RST}" + -boxmap -default {} -type dict + -joins -default {} -type list + -title -default "" -type string -regexprefail {\n}\ + -help "Frame title placed on topbar - no newlines. + May contain ANSI - no trailing reset required. + ${$EG}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${$RST}" + -subtitle -default "" -type string -regexprefail {\n}\ + -help "Frame subtitle placed on bottombar - no newlines + May contain Ansi - no trailing reset required." + -width -default "" -type int\ + -help "Width of resulting frame including borders. + If omitted or empty-string, the width will be determined automatically based on content." + -height -default "" -type int\ + -help "Height of resulting frame including borders." + -ansiborder -default "" -type ansistring\ + -help "Ansi escape sequence to set border attributes. + ${$EG}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${$RST}" + -ansibase -default "" -type ansistring\ + -help "Default ANSI attributes within frame." + -blockalign -default centre -choices {left right centre}\ + -help "Alignment of the content block within the frame." + -pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background + extends within the content block inside the frame. + Has no effect if no ANSI in content." + -textalign -default left -choices {left right centre}\ + -help "Alignment of text within the content block. (centre unimplemented)" + -ellipsis -default 1 -type boolean\ + -help "Whether to show elipsis for truncated content and title/subtitle." + -usecache -default 1 -type boolean + -buildcache -default 1 -type boolean + -crm_mode -default 0 -type boolean\ + -help "Show ANSI control characters within frame contents. + (Control Representation Mode) + Frame width doesn't adapt and content may be truncated + so -width may need to be manually set to display more." + + *values -min 0 -max 1 + contents -default "" -type string\ + -help "Frame contents - may be a block of text containing newlines and ANSI. + Text may be 'ragged' - ie unequal line-lengths. + No trailing ANSI reset required. + ${$EG}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${$RST}" + }] $args] + set opts [dict get $argd opts] + set contents [dict get $argd values contents] + } + + # -- --- --- --- --- --- + # cache relevant + set opt_usecache [tcl::dict::get $opts -usecache] + set opt_buildcache [tcl::dict::get $opts -buildcache] + set usecache $opt_usecache ;#may need to override + set opt_etabs [tcl::dict::get $opts -etabs] ;#affects contentwidth - needed before cache determination + set opt_crm_mode [tcl::dict::get $opts -crm_mode] # -- --- --- --- --- --- - set opt_etabs [tcl::dict::get $opts -etabs] set opt_type [tcl::dict::get $opts -type] set opt_boxlimits [tcl::dict::get $opts -boxlimits] set opt_joins [tcl::dict::get $opts -joins] set opt_boxmap [tcl::dict::get $opts -boxmap] - set opt_usecache [tcl::dict::get $opts -usecache] - set opt_buildcache [tcl::dict::get $opts -buildcache] - set opt_pad [tcl::dict::get $opts -pad] - set opt_crm_mode [tcl::dict::get $opts -crm_mode] - set usecache $opt_usecache ;#may need to override set buildcache $opt_buildcache + set opt_pad [tcl::dict::get $opts -pad] + # -- --- --- --- --- --- + set opt_title [tcl::dict::get $opts -title] + set opt_subtitle [tcl::dict::get $opts -subtitle] + set opt_width [tcl::dict::get $opts -width] + set opt_height [tcl::dict::get $opts -height] + # -- --- --- --- --- --- + set opt_ansiborder [tcl::dict::get $opts -ansiborder] + set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_blockalign [tcl::dict::get $opts -blockalign] set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] set known_frametypes $frametypes ;# light, heavey etc as defined in the ::textblock::frametypes variable @@ -6692,6 +7402,7 @@ tcl::namespace::eval textblock { } } } + #review vllj etc? if {!$is_boxlimits_ok} { error "frame option -boxlimits '$opt_boxlimits' must contain only values from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" } @@ -6708,7 +7419,7 @@ tcl::namespace::eval textblock { } } switch -- $target { - "" - light - heavy - ascii - altg - arc - double - custom - block - block1 - block2 {} + "" - light - light_b - light_c - heavy - heavy_b - heavy_c - ascii - altg - arc - arc_b - arc_c - double - custom - block - block1 - block2 {} default { set is_joins_ok 0 break @@ -6719,11 +7430,10 @@ tcl::namespace::eval textblock { error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" } set is_boxmap_ok 1 - #safe jumptable test - #dict for {boxelement subst} $opt_boxmap {} tcl::dict::for {boxelement subst} $opt_boxmap { switch -- $boxelement { hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + hltj - hlbj - vllj - vlrj {} default { set is_boxmap_ok 0 break @@ -6731,7 +7441,7 @@ tcl::namespace::eval textblock { } } if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" } #sorted order down left right up @@ -6756,13 +7466,8 @@ tcl::namespace::eval textblock { set do_joins [::join $join_directions _] - # -- --- --- --- --- --- - set opt_title [tcl::dict::get $opts -title] - set opt_subtitle [tcl::dict::get $opts -subtitle] - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - # -- --- --- --- --- --- - set opt_blockalign [tcl::dict::get $opts -blockalign] + + #JMN switch -- $opt_blockalign { left - right - centre - center {} default { @@ -6778,11 +7483,7 @@ tcl::namespace::eval textblock { error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" } } - # -- --- --- --- --- --- - set opt_ansiborder [tcl::dict::get $opts -ansiborder] - set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental - set opt_ellipsis [tcl::dict::get $opts -ellipsis] # -- --- --- --- --- --- if {$has_contents} { @@ -6793,10 +7494,11 @@ tcl::namespace::eval textblock { set tw 8 } if {$opt_etabs} { + #todo set contents [textutil::tabify::untabify2 $contents $tw] } } - set contents [tcl::string::map [list \r\n \n] $contents] + set contents [tcl::string::map {\r\n \n} $contents] if {$opt_crm_mode} { if {$opt_height eq ""} { set h [textblock::height $contents] @@ -6809,9 +7511,13 @@ tcl::namespace::eval textblock { set w [expr {$opt_width -2}] } set contents [overtype::renderspace -crm_mode 1 -wrap 1 -width $w -height $h "" $contents] + set actual_contentwidth $w + set actual_contentheight $h + } else { + #set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) + #set actual_contentheight [textblock::height $contents] + lassign [textblock::size_as_list $contents] actual_contentwidth actual_contentheight } - set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) - set actual_contentheight [textblock::height $contents] } else { set actual_contentwidth 0 set actual_contentheight 0 @@ -6824,6 +7530,7 @@ tcl::namespace::eval textblock { set titlewith 0 set content_or_title_width $actual_contentwidth } + #opt_subtitle ?? if {$opt_width eq ""} { set frame_inner_width $content_or_title_width @@ -6847,7 +7554,9 @@ tcl::namespace::eval textblock { variable frame_cache #review - custom frame affects frame_inner_width - exclude from caching? #set cache_key [concat $arglist $frame_inner_width $frame_inner_height] - set hashables [concat $arglist $frame_inner_width $frame_inner_height] + #jmn + #set hashables [concat $arglist $frame_inner_width $frame_inner_height] + set hashables [list {*}$arglist $frame_inner_width $frame_inner_height] if {$use_md5} { #package require md5 ;#already required at package load @@ -7207,7 +7916,12 @@ tcl::namespace::eval textblock { } } #set body [textblock::join -- {*}$bodyparts] - set cache_body [textblock::join -- {*}$cache_bodyparts] + + #JMN test + #assert - lhs, cache_inner, rhs non-ragged - so can use join_basic REVIEW + #set cache_body [textblock::join -- {*}$cache_bodyparts] + set cache_body [textblock::join_basic -- {*}$cache_bodyparts] + append fscached $cache_body #append fs $body } @@ -7259,11 +7973,13 @@ tcl::namespace::eval textblock { #review if {[tcl::string::is integer -strict $opt_height] && $actual_contentheight < ($opt_height -2)} { set diff [expr {($opt_height -2) - $actual_contentheight}] - append contents [::join [lrepeat $diff \n] ""] + append contents [::join [lrepeat $diff \n] ""] ;# should not affect actual_contentwidth } + #set cwidth [textblock::width $contents] + set cwidth $actual_contentwidth if {$opt_pad} { - set paddedcontents [textblock::pad $contents -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) + set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) set paddedwidth [textblock::widthtopline $paddedcontents] #review - horizontal truncation if {$paddedwidth > $cache_patternwidth} { @@ -7272,11 +7988,10 @@ tcl::namespace::eval textblock { #important to supply end of opts -- to textblock::join - particularly here with arbitrary data set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays } else { - set cwidth [textblock::width $contents] if {$cwidth > $cache_patternwidth} { set contents [overtype::renderspace -width $cache_patternwidth "" $contents] } - set contentblock [textblock::join -- $contents] + set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line } set tlines [split $template \n] diff --git a/src/vendormodules/fauxlink-0.1.1.tm b/src/vendormodules/fauxlink-0.1.1.tm index 7aff6ec0..5d63ffef 100644 --- a/src/vendormodules/fauxlink-0.1.1.tm +++ b/src/vendormodules/fauxlink-0.1.1.tm @@ -34,7 +34,7 @@ #[para] The + symbol substitutes for forward-slashes. #[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) #[para] We deliberately treat higher % sequences literally. -#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [heart]) can remain literal for linking to urls. +#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls. #[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 #[para] e.g a link to a file file#A.txt in parent dir could be: #[para] file%23A.txt#..+file%23A.txt.fxlnk @@ -46,7 +46,7 @@ #[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined #[para] Extensions to behaviour should be added in the file as text data in Toml format, #[para] with custom data being under a single application-chosen table name -#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system. +#[para] The toplevel Toml table [lb]fauxlink[rb] is reserved for core extensions to this system. #[para] Aside from the 2 used for delimiting (+ #) #[para] certain characters which might normally be allowed in filesystems are required to be encoded #[para] e.g space and tab are required to be %20 %09 diff --git a/src/vendormodules/overtype-1.6.5.tm b/src/vendormodules/overtype-1.6.5.tm index 3c200d26..e78727d0 100644 --- a/src/vendormodules/overtype-1.6.5.tm +++ b/src/vendormodules/overtype-1.6.5.tm @@ -1366,7 +1366,8 @@ tcl::namespace::eval overtype { if {$overflowlength > 0} { #overlay line wider or equal - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + #review - we still expand_right for centred for now.. possibly should expand_both with ellipsis each end? + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] set rendered [tcl::dict::get $rinfo result] set overflow_right [tcl::dict::get $rinfo overflow_right] set unapplied [tcl::dict::get $rinfo unapplied] @@ -1547,7 +1548,7 @@ tcl::namespace::eval overtype { } else { #padded overtext #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset + #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] lappend outputlines [tcl::dict::get $rinfo result] } diff --git a/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm index ce26471d..f57b4317 100644 --- a/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm @@ -1,16 +1,16 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2024 +# (C) Julian Noble 2024 # # @@ Meta Begin # Application argparsingtest 0.1.0 # Meta platform tcl -# Meta license +# Meta license MIT # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_argparsingtest 0 0.1.0] +#[manpage_begin punkshell_module_argparsingtest 0 0.1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -277,7 +277,7 @@ namespace eval argparsingtest { #punk::args is slower than argp - but comparable, and argp doesn't support solo flags proc test1_punkargs {args} { set argd [punk::args::get_dict { - *proc -name argtest4 -description "test of punk::args::get_dict comparative performance" + *proc -name argtest4 -help "test of punk::args::get_dict comparative performance" *opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -296,7 +296,7 @@ namespace eval argparsingtest { } proc test1_punkargs_validate_without_ansi {args} { set argd [punk::args::get_dict { - *proc -name argtest4 -description "test of punk::args::get_dict comparative performance" + *proc -name argtest4 -help "test of punk::args::get_dict comparative performance" *opts -anyopts 0 -return -default string -type string -choices {string object} -help "return type" -frametype -default \uFFEF -type string diff --git a/src/vfs/_vfscommon.vfs/modules/fauxlink-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/fauxlink-0.1.1.tm index 7aff6ec0..5d63ffef 100644 --- a/src/vfs/_vfscommon.vfs/modules/fauxlink-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/fauxlink-0.1.1.tm @@ -34,7 +34,7 @@ #[para] The + symbol substitutes for forward-slashes. #[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) #[para] We deliberately treat higher % sequences literally. -#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [heart]) can remain literal for linking to urls. +#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls. #[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 #[para] e.g a link to a file file#A.txt in parent dir could be: #[para] file%23A.txt#..+file%23A.txt.fxlnk @@ -46,7 +46,7 @@ #[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined #[para] Extensions to behaviour should be added in the file as text data in Toml format, #[para] with custom data being under a single application-chosen table name -#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system. +#[para] The toplevel Toml table [lb]fauxlink[rb] is reserved for core extensions to this system. #[para] Aside from the 2 used for delimiting (+ #) #[para] certain characters which might normally be allowed in filesystems are required to be encoded #[para] e.g space and tab are required to be %20 %09 diff --git a/src/vfs/_vfscommon.vfs/modules/modpodtest-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/modpodtest-0.1.0.tm index d65e9ca5..55decf05 100644 Binary files a/src/vfs/_vfscommon.vfs/modules/modpodtest-0.1.0.tm and b/src/vfs/_vfscommon.vfs/modules/modpodtest-0.1.0.tm differ diff --git a/src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm b/src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm index 3c200d26..e78727d0 100644 --- a/src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm +++ b/src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm @@ -1366,7 +1366,8 @@ tcl::namespace::eval overtype { if {$overflowlength > 0} { #overlay line wider or equal - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + #review - we still expand_right for centred for now.. possibly should expand_both with ellipsis each end? + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] set rendered [tcl::dict::get $rinfo result] set overflow_right [tcl::dict::get $rinfo overflow_right] set unapplied [tcl::dict::get $rinfo unapplied] @@ -1547,7 +1548,7 @@ tcl::namespace::eval overtype { } else { #padded overtext #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset + #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] lappend outputlines [tcl::dict::get $rinfo result] } diff --git a/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm b/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm index ac1782ba..7d37a2cd 100644 --- a/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm @@ -13,6 +13,7 @@ package require pattern package require overtype +package require punk::ansi package require punk::lib pattern::init @@ -76,7 +77,7 @@ set ::punk::bannerTemplate [string trim { } else { lassign $cborder_ctext cborder ctext } - return [textblock::frame -type arc -ansiborder [a+ Web-black $cborder] [a+ Web-black $ctext][$this . logo2]] + return [ textblock::frame-type arc -ansiborder [a+ Web-black $cborder] [a+ Web-black $ctext][$this . logo2]] } >punk .. Property logotk "\[TCL\\\n TK \]" proc TCL {args} { @@ -108,6 +109,45 @@ proc TCL {args} { } return $version } +>punk .. Method poses {args} { + set argd [punk::args::get_dict { + *proc -name ">punk . poses" -help "Show or list the poses for the Punk mascot" + -censored -default 1 -type boolean -help "Set true to include mild toilet humour poses" + -return -default table -choices {list table} + } $args] + set censored [dict get $argd opts -censored] + set return [dict get $argd opts -return] + + set poses [list\ + front\ + back\ + lhs\ + left\ + rhs\ + right\ + lhs_air\ + rhs_air\ + lhs_hips\ + rhs_hips\ + lhs_bend\ + rhs_bend\ + lhs_thrust\ + rhs_thrust\ + ] + if {!$censored} { + #allow toilet humour + lappend poses piss poop + } + if {$return eq "list"} { + return $poses + } + set cells [list] + foreach pose $poses { + lappend cells "$pose\n\n[>punk . $pose]" + } + textblock::list_as_table -show_hseps 1 -columns 4 $cells +} + >punk .. Property front [string trim { _|_ @ v @ @@ -266,7 +306,7 @@ _+ +_ _- -_ \ // / \\ - _+_+ + +_+_ } \n] >punk .. Property rhs_thrust [string trim { \\\_ @@ -275,7 +315,7 @@ _+ +_ _- -_ \ \\ / // - _+_+ + +_+_ } \n] >punk .. Property fossil [string trim { @@ -287,6 +327,38 @@ v \\_/ v_ /|\/ / \__/ } \n] +>punk .. Method deck {args} { + #todo - themes? + set this @this@ + set RST [a] + set punk_colour [a+ term-71] ;#term-darkseagreen4-b + set hbar_colour [a+ web-silver] + set vbar_colour [a+ web-steelblue] + set border_colour [a+ web-lightslategray] + set frame_type arc + set punk $punk_colour[$this . lhs_air]$RST + package require punk::args + set standard_frame_types [textblock::frametypes] + set argd [punk::args::get_dict [tstr -return string { + *proc -name "deck" -help "Punk Deck mascot" + -frame -default arc -choices "${$standard_frame_types}" -choicerestricted 0 -choiceprefix 1 + -boxmap -default {} -type dict + -boxlimits -default {hl vl tlc blc trc brc} -help "Limit the border box to listed elements." + -border_colour -default ${$border_colour} -type ansistring -regexprepass {^$} -validationtransform { + -function stripansi -maxlen 0 + } + -title -default "PATTERN" -type string + -subtitle -default "PUNK" -type string + *values -max 0 + }] $args] + set frame_type [dict get $argd opts -frame] + set box_map [dict get $argd opts -boxmap] + set box_limits [dict get $argd opts -boxlimits] + set border_colour [dict get $argd opts -border_colour] + set title [dict get $argd opts -title] + set subtitle [dict get $argd opts -subtitle] + set punkdeck [overtype::right [overtype::left [textblock::frame -ansiborder $border_colour -type $frame_type -boxmap $box_map -boxlimits $box_limits -title $hbar_colour$title$RST -subtitle $hbar_colour$subtitle$RST $punk] "$vbar_colour\n\n\P\nU\nN\nK$RST"] "$vbar_colour\n\nD\nE\nC\nK"] +} >punk .. Method gcross {{size 1} args} { package require textblock textblock::gcross {*}$args $size diff --git a/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm index cb063270..1765fc20 100644 --- a/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -18,12 +18,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_poshinfo 0 0.1.0] +#[manpage_begin punkshell_module_poshinfo 0 0.1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[titledesc {poshinfo prompt theme tool}] [comment {-- Name section and table of contents description --}] +#[moddesc {POSH-related prompt tool}] [comment {-- Description at end of page heading --}] #[require poshinfo] -#[keywords module] +#[keywords module terminal console theme prompt {prompt theme} POSH] #[description] #[para] - @@ -49,6 +49,7 @@ package require Tcl 8.6- package require punk::config package require json ;#tcllib #toml, yaml? +package require punk::args #*** !doctools #[item] [package {Tcl 8.6}] @@ -71,9 +72,11 @@ package require json ;#tcllib # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #tcl::namespace::eval poshinfo::class { + #*** !doctools #[subsection {Namespace poshinfo::class}] #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { #*** !doctools #[list_begin enumerated] @@ -96,6 +99,7 @@ package require json ;#tcllib #*** !doctools #[list_end] [comment {--- end class enumeration ---}] + #} #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -114,18 +118,6 @@ tcl::namespace::eval poshinfo { - #proc sample1 {p1 n args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 - # #[para] Arguments: - # # [list_begin arguments] - # # [arg_def tring p1] A description of string argument p1. - # # [arg_def integer n] A description of integer argument n. - # # [list_end] - # return "ok" - #} - proc info_from_filename {fname} { #string based filename processing: we are deliberately avoiding test of file existence etc here if {$fname eq ""} { @@ -137,7 +129,12 @@ tcl::namespace::eval poshinfo { } set ftail [file tail $fname] set rootname [file rootname $ftail] - set format [string trimleft [file extension $ftail] .] + set extension [string trimleft [file extension $ftail] .] + if {$extension eq "yml"} { + set format "yaml" + } else { + set format $extension + } set parts [split $rootname .] if {[lindex $parts end] eq "omp"} { set type omp @@ -146,54 +143,122 @@ tcl::namespace::eval poshinfo { if {$rootname eq "schema"} { set type schema } else { + #review - we can't tell diff betw . and .. set type unknown } set shortname $rootname } - return [dict create shortname $shortname format $format type $type] + return [dict create shortname $shortname format $format extension $extension type $type] } - proc themes_dict {{globfor *}} { + #restrict glob to filename in filename.. + proc Themes_dict {{globlist *}} { set running_config [punk::config::get running-config] set posh_themes_path [tcl::dict::get $running_config posh_themes_path] #posh_themes_path_extra ?? - set themes [tcl::dict::create] + set themes_dict [tcl::dict::create] if {[string length $posh_themes_path]} { if {[file exists $posh_themes_path]} { - set files [glob -nocomplain -directory $posh_themes_path -tails $globfor] + set files [glob -nocomplain -directory $posh_themes_path -tails -- {*}$globlist] foreach ftail $files { set themeinfo [info_from_filename $ftail] set shortname [dict get $themeinfo shortname] - dict set themeinfo path [file join $posh_themes_path $ftail] - if {![dict exists $themes $shortname]} { - dict set themes $shortname [list $themeinfo] - } else { - dict lappend themes $shortname $themeinfo + + set name_matched 0 + foreach glob $globlist { + if {[string match -nocase $glob $shortname]} { + set name_matched 1 + break + } + } + if {$name_matched} { + dict set themeinfo path [file join $posh_themes_path $ftail] + if {![dict exists $themes_dict $shortname]} { + dict set themes_dict $shortname [list $themeinfo] + } else { + dict lappend themes_dict $shortname $themeinfo + } } } } } - return $themes + return $themes_dict + } + proc get_active_theme {} { + lassign [punk::config::get running posh_theme] _ themepath + set theme_info [info_from_filename $themepath] + dict set theme_info path $themepath + } + proc set_active_theme_by_name {name} { + error "unimplemented" } - proc themes {{globfor *}} { - set themes [themes_dict $globfor] + proc set_active_theme_by_path {path} { + error "unimplemented" + } + proc themes {args} { + set argd [punk::args::get_dict { + *id poshinfo::themes + *proc -name poshinfo::themes + -format -default all -multiple 1 -choices {all yaml json}\ + -help "File format of posh theme - based on file extension" + -type -default all -multiple 1\ + -help "e.g omp" + -as -default "table" -choices {list showlist dict showdict table tableobject plaintext}\ + -help "return type of result" + *values -min 0 + globs -multiple 1 -default * -help "" + } $args] + set return_as [dict get $argd opts -as] + set formats [dict get $argd opts -format] ;#multiple + if {"yaml" in $formats} { + lappend formats "yml" ;#unpreferred extension for yaml - but accepted + } + set types [dict get $argd opts -type] ;#multiple + set globlist [dict get $argd values globs] + + set themes_dict [Themes_dict $globlist] + set restricted_themes_dict [dict create] + dict for {shortname themeinfolist} $themes_dict { + set themeinfo [lindex $themeinfolist 0] + if {("all" in $formats || [dict get $themeinfo format] in $formats) && ("all" in $types || [dict get $themeinfo type] in $types)} { + dict set restricted_themes_dict $shortname $themeinfolist + } + } + unset themes_dict + switch -- $return_as { + dict { + return $restricted_themes_dict + } + showdict { + return [showdict $restricted_themes_dict */@*/@*.@*] + } + list { + return [dict keys $restricted_themes_dict] + } + showlist { + return [showlist [dict keys $restricted_themes_dict]] + } + } + set posh_theme [file normalize [punk::config::get_running_global posh_theme]] set t [textblock::class::table new "Posh Themes"] $t configure -show_header 1 -show_hseps 0 $t add_column -headers Shortname $t add_column -headers Path - dict for {shortname themeinfolist} $themes { + dict for {shortname themeinfolist} $restricted_themes_dict { #hack - support just one for now set themeinfo [lindex $themeinfolist 0] set path [dict get $themeinfo path] $t add_row [list $shortname $path] + set fg "" set bg "" switch -- [dict get $themeinfo type] { schema { + set fg black set bg Web-orange } omp {} @@ -212,9 +277,22 @@ tcl::namespace::eval poshinfo { $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fg {*}$bg] } } - set result [$t print] - $t destroy - return $result + switch -- $return_as { + plaintext { + $t configure -frametype {} + set tabletext [$t print] + set pt [punk::ansi::ansistrip $tabletext] + return [join [lines_as_list -line trimline $pt] \n] + } + table { + set tabletext [$t print] + $t destroy + return $tabletext + } + tableobject { + return $t + } + } } @@ -230,6 +308,7 @@ tcl::namespace::eval poshinfo { tcl::namespace::eval poshinfo::lib { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase tcl::namespace::path [tcl::namespace::parent] + #*** !doctools #[subsection {Namespace poshinfo::lib}] #[para] Secondary functions that are part of the API @@ -254,7 +333,9 @@ tcl::namespace::eval poshinfo::lib { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Internal] + #tcl::namespace::eval poshinfo::system { + #*** !doctools #[subsection {Namespace poshinfo::system}] #[para] Internal functions that are not part of the API diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm index 4bd8aae0..59efcc9c 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm @@ -7326,21 +7326,28 @@ namespace eval punk { if {$topic in [list tcl]} { - if {[punk::lib::system::has_tclbug_script_var]} { - append warningblock \n "minor warning: punk::lib::system::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" + if {[punk::lib::check::has_tclbug_script_var]} { + append warningblock \n "minor warning: punk::lib::check::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" } - if {[punk::lib::system::has_tclbug_safeinterp_compile]} { + if {[punk::lib::check::has_tclbug_safeinterp_compile]} { set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_safeinterp returned true!" \n + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_safeinterp returned true!" \n append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n - append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/1095bf7f75" + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/1095bf7f75]" append warningblock [a] } - if {[punk::lib::system::has_tclbug_list_quoting_emptyjoin]} { + if {[punk::lib::check::has_tclbug_lsearch_strideallinline]} { set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_list_quoting returned true!" \n + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_lsearch_strideallinline returned true!" \n + append warningblock "${indent}(lsearch using -stride -all -inline -subindices does not return values corresponding to subindex when a single -index value is used)" \n + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/5a1aaa201d]" + append warningblock [a] + } + if {[punk::lib::check::has_tclbug_list_quoting_emptyjoin]} { + set indent " " + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_list_quoting returned true!" \n append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n - append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/e38dce74e2" + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/e38dce74e2]" } } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm index 83c02d0b..22b3d5bf 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,12 +18,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::aliascore 0 0.1.0] +#[manpage_begin punkshell_module_punk::aliascore 0 0.1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[titledesc {punkshell command aliases}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::aliascore] -#[keywords module] +#[keywords module alias] #[description] #[para] - diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm index 1a40c952..ba5bcf90 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm @@ -417,8 +417,11 @@ tcl::namespace::eval punk::ansi { convert*\ clear*\ cursor_*\ + delete*\ detect*\ + erase*\ get_*\ + hyperlink\ move*\ reset*\ ansistrip*\ @@ -618,7 +621,7 @@ tcl::namespace::eval punk::ansi { set subtitle [tcl::dict::get $picinfo status] } set title [tcl::dict::get $picinfo filename] - set fr [textblock::frame -width $colwidth -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] + set fr [textblock::frame -checkargs 0 -width $colwidth -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] # -- --- --- --- #we need the max height of a row element to use join_basic instead of join below # -- --- --- --- @@ -3096,6 +3099,18 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return "\033\[?25l" } + # REVIEW - osc8 replays etc for split lines? - textblock + #the 'id' parameter logically connects split hyperlinks + proc hyperlink {uri {display ""}} { + if {$display eq ""} { + set display $uri + } + set params "" ;#todo e.g id=xyz123:foo=bar:baz=quux + set open "\x1b\]8\;$params\;$uri\x1b\\" + set close "\x1b\]8\;\;\x1b\\" + return ${open}${display}${close} + } + # -- --- --- --- --- proc move {row col} { #*** !doctools @@ -3634,11 +3649,27 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } set parts [punk::ansi::ta::split_codes $text] set out "" + #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" + # - (if/when lsearch -stride bug fixed) foreach {pt code} $parts { append out $pt } return $out } + proc ansistrip2 {text} { + #*** !doctools + #[call [fun ansistrip] [arg text] ] + #[para]Return a string with ansi codes stripped out + #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) + + if {[punk::ansi::ta::detect_g0 $text]} { + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + } + set parts [punk::ansi::ta::split_codes $text] + #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" + # - (if/when lsearch -stride bug fixed) + join [lmap v [lseq 0 to [llength $parts] by 2] {lindex $parts $v}] "" ;#slightly slower than above foreach + } #interp alias {} stripansi {} ::punk::ansi::ansistrip proc ansistripraw {text} { #*** !doctools @@ -3842,8 +3873,9 @@ tcl::namespace::eval punk::ansi { proc sgr_merge {codelist args} { set allparts [list] foreach c $codelist { - set cparts [punk::ansi::ta::split_codes_single $c] - lappend allparts {*}[lsearch -all -inline -not $cparts ""] + #set cparts [punk::ansi::ta::split_codes_single $c] + #lappend allparts {*}[lsearch -all -inline -not $cparts ""] + lappend allparts {*}[punk::ansi::ta::get_codes_single $c] } sgr_merge_singles $allparts {*}$args } @@ -4362,10 +4394,12 @@ tcl::namespace::eval punk::ansi::ta { # -- --- --- --- variable re_ansi_detect1 "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" # -- --- --- --- - #handrafted TRIE version of above. Somewhat difficult to construct and maintain. TODO - find a regext TRIE generator that works with Tcl regexes + #handrafted TRIE version of above. Somewhat difficult to construct and maintain. TODO - find a regexp TRIE generator that works with Tcl regexes #This does make things quicker - but it's too early to finalise the detect/split regexes (e.g missing \U0090 ) - will need to be redone. - variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} + #variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} + variable re_ansi_detect {(?:\x1b(?:\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\((?:0|B)|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} # -- --- --- --- + #variable re_csi_code {(?:\x1b\[|\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]} @@ -4389,9 +4423,7 @@ tcl::namespace::eval punk::ansi::ta { #can be used on dicts - but will check keys too. keys could also contain ansi and have escapes proc detect_in_list {list} { - detect [join $list " "] - } - proc detect_in_list2 {list} { + #loop is commonly faster than using join. (certain ansi codes triggering list quoting? review) foreach item $list { if {[detect $item]} { return 1 @@ -4399,6 +4431,11 @@ tcl::namespace::eval punk::ansi::ta { } return 0 } + #surprisingly - the ::join operation can be (relatively) slow on lists containing ansi + proc detect_in_list2 {list} { + detect [join $list " "] + } + proc detect_g0 {text} [string map [list [list $re_g0_group]] { regexp $text }] @@ -4580,13 +4617,108 @@ tcl::namespace::eval punk::ansi::ta { #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds) #- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped. - proc split_codes_single {text} { + proc split_codes_single2 {text} { variable re_ansi_split return [_perlish_split $re_ansi_split $text] } + proc split_codes_single3 {text} { + #copy from re_ansi_split + _perlish_split {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} $text + } + proc split_codes_single4 {text} { + if {$text eq ""} { + return {} + } + variable re_ansi_split + set re $re_ansi_split + #variable re_ansi_detect1 + #set re $re_ansi_detect1 + set list [list] + set start 0 + + #set re {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + #while {[regexp -start $start -indices -- {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} $text match]} {} + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + lappend list [tcl::string::range $text $start $matchStart-1] + if {$matchEnd < $matchStart} { + set e $matchStart + incr start + } else { + set e $matchEnd + set start [expr {$matchEnd+1}] + } + lappend list [tcl::string::range $text $matchStart $e] + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + proc split_codes_single {text} { + if {$text eq ""} { + return {} + } + variable re_ansi_split + set next 0 + set b -1 + set list [list] + set coderanges [regexp -indices -all -inline -- $re_ansi_split $text] + foreach cr $coderanges { + lappend list [tcl::string::range $text $next [lindex $cr 0]-1] [tcl::string::range $text [lindex $cr 0] [lindex $cr 1]] + set next [expr {[lindex $cr 1]+1}] + } + lappend list [tcl::string::range $text $next end] + return $list + } + proc get_codes_single {text} { + variable re_ansi_split + regexp -all -inline -- $re_ansi_split $text + } #review - tcl greedy expressions may match multiple in one element proc _perlish_split {re text} { + if {$text eq ""} { + return {} + } + set next 0 + set b -1 + set list [list] + set coderanges [regexp -indices -all -inline -- $re $text] + foreach cr $coderanges { + lappend list [tcl::string::range $text $next [lindex $cr 0]-1] [tcl::string::range $text [lindex $cr 0] [lindex $cr 1]] + set next [expr {[lindex $cr 1]+1}] + } + lappend list [tcl::string::range $text $next end] + return $list + } + proc _perlish_split2 {re text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchStart] + incr start + } else { + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + set start [expr {$matchEnd+1}] + } + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + proc _perlish_split3 {re text} { if {$text eq ""} { return {} } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm index bd4f70fe..4100b104 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm @@ -256,10 +256,10 @@ tcl::namespace::eval punk::args::class { tcl::namespace::eval punk::args { tcl::namespace::export {[a-z]*} variable argspec_cache - variable argspecs + variable argspec_ids variable id_counter - set argspec_cache [tcl::dict::create] - set argspecs [tcl::dict::create] + set argspec_cache [tcl::dict::create] + set argspec_ids [tcl::dict::create] set id_counter 0 #*** !doctools @@ -296,12 +296,15 @@ tcl::namespace::eval punk::args { return $result } - #todo? -synonym ? (applies to opts only not values) - #e.g -background -synonym -bg -default White + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix e.g -corner -aliases {-corners} + #We mightn't want the prefix to be longer just because of an alias proc Get_argspecs {optionspecs args} { variable argspec_cache - variable argspecs + #variable argspecs ;#REVIEW!! + variable argspec_ids variable initial_optspec_defaults variable initial_valspec_defaults #ideally we would use a fast hash algorithm to produce a short key with low collision probability. @@ -319,31 +322,37 @@ tcl::namespace::eval punk::args { -type string\ -optional 1\ -allow_ansi 1\ - -validate_without_ansi 0\ + -validate_ansistripped 0\ -strip_ansi 0\ -nocase 0\ -choiceprefix 1\ + -choicerestricted 1\ -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ ] set valspec_defaults [tcl::dict::create\ -type string\ -optional 0\ -allow_ansi 1\ - -validate_without_ansi 0\ + -validate_ansistripped 0\ -strip_ansi 0\ -nocase 0\ -choiceprefix 1\ + -choicerestricted 1\ -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ ] - #we need a -choiceprefix default even though it often doesn't apply so we can look it up to display in Help if there are -choices + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices #default to 1 for convenience #checks with no default #-minlen -maxlen -range - #default -allow_ansi to 1 and -validate_without_ansi to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_without_ansi 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist set opt_required [list] set val_required [list] set arg_info [tcl::dict::create] @@ -465,7 +474,7 @@ tcl::namespace::eval punk::args { -anyopts { set opt_any $v } - -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix { + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted { #review - only apply to certain types? tcl::dict::set optspec_defaults $k $v } @@ -488,30 +497,31 @@ tcl::namespace::eval punk::args { dict - dictionary { set v dict } - none - any - ansistring { - - } - list { + none - "" - - - any - ansistring - globstring - list { } default { #todo - disallow unknown types unless prefixed with custom- } } - tcl::dict::set optspec_defaults $k $v + tcl::dict::set optspec_defaults -type $v } -optional - -allow_ansi - - -validate_without_ansi - + -validate_ansistripped - -strip_ansi - + -regexprepass - + -regexprefail - + -validationtransform - -multiple { #allow overriding of defaults for options that occur later tcl::dict::set optspec_defaults $k $v } default { - set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\ + set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -validationtransform\ } error "punk::args::Get_argspecs - unrecognised key '$k' in *opts line. Known keys: $known" } @@ -523,13 +533,19 @@ tcl::namespace::eval punk::args { switch -- $k { -min - -minvalues { + if {$v < 0} { + error "punk::args::Get_argspecs - minimum acceptable value for key '$k' in *opts line is 0. got $v" + } set val_min $v } -max - -maxvalues { + if {$v < -1} { + error "punk::args::Get_argspecs - minimum acceptable value for key '$k' in *opts line is -1 (indicating unlimited). got $v" + } set val_max $v } - -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -nocase { + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set valspec_defaults $k $v } @@ -563,16 +579,20 @@ tcl::namespace::eval punk::args { } -optional - -allow_ansi - - -validate_without_ansi - + -validate_ansistripped - -strip_ansi - + -regexprepass - + -regexprefail - + -validationtransform - -multiple { tcl::dict::set valspec_defaults $k $v } default { set known { -min -minvalues -max -maxvalues\ - -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\ + -minlen -maxlen -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -validationtransform\ } error "punk::args::Get_argspecs - unrecognised key '$k' in *values line. Known keys: $known" } @@ -637,30 +657,59 @@ tcl::namespace::eval punk::args { error "punk::args::get_dict - invalid -type 'none' for positional argument positional argument '$argname'" } } - any - ansistring { + any - anything { tcl::dict::set spec_merged -type any } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } 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] } } } - -default - -solo - -range - -choices - -choiceprefix - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { + -default - -solo - -range - -choices - -choiceprefix - -choicerestricted - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail + { #review -solo 1 vs -type none ? tcl::dict::set spec_merged $spec $specval } + -validationtransform { + #string is dict only 8.7/9+ + if {([llength $specval] % 2) != 0} { + error "punk::args::get_dict - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minlen - -maxlen - -range { + } + default { + set known_transform_keys [list -function -type -minlen -maxlen -range] ;#-choices etc? + error "punk::args::get_dict - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys" + } + } + } + + } default { - set known_argspecs [list -default -type -range -choices -choiceprefix -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help] + set known_argspecs [list -default -type -range -choices -choiceprefix -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -validationtransform\ + ] error "punk::args::get_dict - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" } } } set argspecs $spec_merged if {$is_opt} { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen + set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen } else { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen + set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen } tcl::dict::set arg_info $argname $argspecs tcl::dict::set arg_checks $argname $argchecks @@ -693,8 +742,8 @@ tcl::namespace::eval punk::args { } - set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen - set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen + set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen + set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen set result [tcl::dict::create\ id $spec_id\ @@ -717,30 +766,55 @@ tcl::namespace::eval punk::args { proc_info $proc_info\ ] tcl::dict::set argspec_cache $cache_key $result - tcl::dict::set argspecs $spec_id $optionspecs + #tcl::dict::set argspecs $spec_id $optionspecs + tcl::dict::set argspec_ids $spec_id $optionspecs #puts "xxx:$result" return $result } proc get_spec {id} { - variable argspecs - if {[tcl::dict::exists $argspecs $id]} { - return [tcl::dict::get $argspecs $id] + variable argspec_ids + if {[tcl::dict::exists $argspec_ids $id]} { + return [tcl::dict::get $argspec_ids $id] } return } proc get_spec_ids {{match *}} { - variable argspecs - return [tcl::dict::keys $argspecs $match] + variable argspec_ids + return [tcl::dict::keys $argspec_ids $match] } #for use within get_dict only #This mechanism gets less-than-useful results for oo methods #e.g {$obj} proc Get_caller {} { - set cmdinfo [tcl::dict::get [tcl::info::frame -3] cmd] + set call_level -3 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] #puts "-->$cmdinfo" #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } set caller [regexp -inline {\S+} $cmdinfo] if {$caller eq "namespace"} { set cmdinfo "punk::args::get_dict called from namespace" @@ -748,7 +822,18 @@ tcl::namespace::eval punk::args { return $cmdinfo } + #basic recursion blocker + variable arg_error_isrunning 0 proc arg_error {msg spec_dict {badarg ""}} { + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $badarg" + } + set arg_error_isrunning 1 + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + # use basic colours here to support terminals without extended colours #todo - add checks column (e.g -minlen -maxlen) set errmsg $msg @@ -802,136 +887,120 @@ tcl::namespace::eval punk::args { #set greencheck [a+ web-limegreen]\u2713[a] set greencheck [a+ brightgreen]\u2713[a] - if {![catch {package require punk::trie}]} { - set opt_names_display [list] - set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - set M "\x1b\[32m" ;#mark in green - set RST "\x1b\[m" - foreach c [dict get $spec_dict opt_names] { - set id [dict get $idents $c] - if {$id eq $c} { - lappend opt_names_display $M$c$RST - } else { - set idlen [string length $id] - lappend opt_names_display "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" - } - } - } else { - set opt_names_display [dict get $spec_dict opt_names] - } - - - foreach argshow $opt_names_display arg [dict get $spec_dict opt_names] { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - #set default $c_default[dict get $arginfo -default] - set default [dict get $arginfo -default] - } else { - set default "" - } - set help [::punk::args::Dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - } else { - set casemsg " (case sensitive)" - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - append help "Choices$prefixmsg$casemsg" - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - append help "\n " [join [dict get $arginfo -choices] "\n "] - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - set M "\x1b\[32m" ;#mark in green - set RST "\x1b\[m" - foreach c [dict get $arginfo -choices] { - set id [dict get $idents $c] - if {$id eq $c} { - append help "\n " "$M$c$RST" - } else { - set idlen [string length $id] - append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" - } - } - } errM]} { - puts stderr "prefix marking failed\n$errM" - append help "\n " [join [dict get $arginfo -choices] "\n "] + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict opt_names]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $spec_dict opt_names] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] } - } - } - if {[::punk::args::Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck + lappend opt_names_display $M$prefix$RST$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } } else { - set multiple "" - } - $t add_row [list $argshow [dict get $arginfo -type] $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg + set opt_names [dict get $spec_dict opt_names] + set opt_names_display $opt_names } } - foreach arg [dict get $spec_dict val_names] { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - set default [dict get $arginfo -default] - } else { - set default "" - } - set help [::punk::args::Dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" + set val_names [dict get $spec_dict val_names] + set val_names_display $val_names + + #display options first then values + foreach argumentset [list [list $opt_names_display $opt_names] [list $val_names_display $val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict arg_info $arg] + if {[dict exists $arginfo -default]} { + #set default $c_default[dict get $arginfo -default] + set default [dict get $arginfo -default] } else { - set casemsg " (case sensitive)" + set default "" } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" + set help [::punk::args::Dict_getdef $arginfo -help ""] + if {[dict exists $arginfo -choices]} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + } else { + set casemsg " (case sensitive)" + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set formattedchoices [list] + append help " Choices$prefixmsg$casemsg" + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + set formattedchoices [dict get $arginfo -choices] + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $arginfo -choices] { + set id [dict get $idents $c] + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend formattedchoices "$M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail]" + } + } errM]} { + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + set formattedchoices [dict get $arginfo -choices] + + } + } + set numcols 4 + if {[llength $formattedchoices] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formattedchoices] + } + #risk of recursing + set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices] + append help \n[textblock::join -- " " $choicetable] + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } } - append help "Choices$prefixmsg$casemsg" - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[::punk::args::Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck } else { - if {[catch { - set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - set M "\x1b\[32m" ;#mark in green - set RST "\x1b\[m" - foreach c [dict get $arginfo -choices] { - set id [dict get $idents $c] - if {$id eq $c} { - append help "\n " "$M$c$RST" - } else { - set idlen [string length $id] - append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" - } - } - } errM]} { - puts stderr "prefix marking failed\n$errM" - append help "\n " [join [dict get $arginfo -choices] "\n "] - } + set multiple "" + } + $t add_row [list $argshow [dict get $arginfo -type] $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg } - } - if {[punk::args::Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } - $t add_row [list $arg [dict get $arginfo -type] $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg } } @@ -950,8 +1019,10 @@ tcl::namespace::eval punk::args { } } else { - #todo - something boring + #couldn't load textblock package + #just return the original errmsg without formatting } + set arg_error_isrunning 0 #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. #Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg @@ -962,6 +1033,14 @@ tcl::namespace::eval punk::args { #provide ability to look up and reuse definitions from ids etc # + proc get_dict_by_id {id {arglist ""}} { + set spec [get_spec $id] + if {$spec eq ""} { + error "punk::args::get_dict_by_id - no such id: $id" + } + return [get_dict $spec $arglist] + } + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. #only supports -flag val pairs, not solo options @@ -1054,6 +1133,171 @@ tcl::namespace::eval punk::args { #todo: -minmultiple -maxmultiple ? set opts $opt_defaults + + if {$id ne "jtest"} { + set arglist {} + set values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "arg_info: $arg_info" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + break + } + + if {[tcl::string::match -* $a]} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set values [lrange $rawargs $i+1 end] + } + } else { + #unlimited number of values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set values [lrange $rawargs $i+1 end] + } + break + } else { + set fullopt [tcl::prefix match -error "" $opt_names $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + break + } + + set flagval [lindex $rawargs $i+1] + if {[dict get $arg_info $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + #review - what if user sets first value that happens to match a default? + if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { + #first occurrence of this flag, whilst stored value matches default + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + incr vals_remaining_possible -2 + if {[incr i] > $maxidx} { + arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs $fullopt + } + } else { + #solo + if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $opts $fullopt] == 0} { + #review - what if default at time opt was specified is not zero? we will end up with more items in the list than the number of times the flag was specified + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + incr vals_remaining_possible -1 + } + lappend flagsreceived $fullopt ;#dups ok + } else { + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option + tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $opt_checks_defaults + if {[tcl::dict::get $arg_info $a -type] ne "none"} { + if {[tcl::dict::get $arg_info $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + lappend flagsreceived $a ;#adhoc flag as supplied + if {[incr i] > $maxidx} { + arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $arg_info $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + } + } else { + #set errmsg [tcl::string::map [list %caller% [Get_caller]] $fullopt] + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" + arg_error $errmsg $argspecs $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + break + } + } + } else { + set values $rawargs ;#no -flags detected + set arglist [list] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + } + + + if {$id eq "jtest"} { if {[set eopts [lsearch -exact $rawargs "--"]] >= 0} { lappend flagsreceived -- set values [lrange $rawargs $eopts+1 end] @@ -1233,6 +1477,10 @@ tcl::namespace::eval punk::args { set arglist [list] } } + } + + + set validx 0 set in_multiple "" set valnames_received [list] @@ -1328,7 +1576,7 @@ tcl::namespace::eval punk::args { set thisarg_checks [tcl::dict::get $arg_checks $argname] set is_multiple [tcl::dict::get $thisarg -multiple] set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_without_ansi [tcl::dict::get $thisarg -validate_without_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] set has_default [tcl::dict::exists $thisarg -default] if {$has_default} { @@ -1336,53 +1584,150 @@ tcl::namespace::eval punk::args { } set type [tcl::dict::get $thisarg -type] set has_choices [tcl::dict::exists $thisarg -choices] + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [punk::args::Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + set validationtransform [tcl::dict::get $thisarg -validationtransform] + if {$is_multiple} { set vlist $v } else { set vlist [list $v] } - if {!$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" - } - } - } - if {$is_validate_without_ansi} { - #validate_without_ansi 1 + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 package require punk::ansi set vlist_check [list] foreach e $vlist { lappend vlist_check [punk::ansi::ansistrip $e] } } else { - #validate_without_ansi 0 + #validate_ansistripped 0 set vlist_check $vlist } - set is_default 0 - if {$has_default} { - foreach e_check $vlist_check { - if {$e_check eq $defaultval} { - incr is_default + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + if {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choices [tcl::dict::get $thisarg -choices] + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + set nocase [tcl::dict::get $thisarg -nocase] + if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { + set dname opts + } else { + set dname values_dict + } + set idx 0 ;# + #opts/values_dict $argname membmer 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 { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $choices] + set v_test [tcl::string::tolower $e_check] + } else { + set casemsg " (case sensitive)" + set v_test $e_check + set choices_test $choices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $e eq $defaultval}] + if {!$matches_default} { + if {$choiceprefix} { + set chosen [tcl::prefix::match -error "" $choices_test $v_test] + if {$chosen ne ""} { + set choice_in_list 1 + #can we handle empty string as a choice? It should just work - REVIEW/test + #must use exact in case glob chars present e.g * ? [] (also ansi has square brackets) + set choice [lsearch -exact -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $choice + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $choice + } + } + } else { + set choice_in_list [expr {$v_test in $choices_test}] + } } + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $v_test + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $v_test + } + lappend vlist_validate $e + lappend vlist_check_validate $e_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs $argname + } + } + incr idx } - if {$is_default eq [llength $vlist]} { - set is_default 1 - } else { - #important to set 0 here too e.g if only one element of many matches default - set is_default 0 + #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 + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + if {$e_check ne $defaultval} { + lappend vlist_validate $e + lappend vlist_check_validate $e + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + } } } #puts "argname:$argname v:$v is_default:$is_default" #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. #arguments that are at their default are not subject to type and other checks - if {$is_default == 0} { + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { switch -- $type { any {} list { @@ -1411,9 +1756,66 @@ tcl::namespace::eval punk::args { } } } - string { + 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 e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punk::lib::ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punk::lib::ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + arg_error "Option $argname for [Get_caller] didn't pass regexprefail regex: '$regexprefail' got '$e'" $argspecs $argname + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minlen 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 -minlen 0 -maxlen 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs $argname + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs $argname + } + } + } + } + if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $vlist_check { + foreach e_check $remaining_e_check { #safe jumptable test #dict for {checkopt checkval} $thisarg_checks {} tcl::dict::for {checkopt checkval} $thisarg_checks { @@ -1436,28 +1838,40 @@ tcl::namespace::eval punk::args { } } } - ansistring { - package require ansi - } int { #-range 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 if {[tcl::dict::exists $thisarg -range]} { lassign [tcl::dict::get $thisarg -range] low high - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname - } + if {"$low$high" ne ""} { if {$low eq ""} { - if {$e_check < $low} { - arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs $argname + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname + } + #lowside unspecified - check only high + if {$e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs $argname + } } } elseif {$high eq ""} { - if {$e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs $argname + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname + } + #highside unspecified - check only low + if {$e_check < $low} { + arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs $argname + } } } else { - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs $argname + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs $argname + } } } } @@ -1577,49 +1991,14 @@ tcl::namespace::eval punk::args { } } } - if {$has_choices} { - #todo -choicelabels - set choices [tcl::dict::get $thisarg -choices] - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set nocase [tcl::dict::get $thisarg -nocase] - foreach e $vlist e_check $vlist_check { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $choices] - set v_test [tcl::string::tolower $e_check] - } else { - set casemsg " (case sensitive)" - set v_test $e_check - set choices_test $choices - } - set choice_ok 0 - if {$choiceprefix} { - if {![catch {tcl::prefix::match $choices_test $v_test} chosen]} { - set choice_ok 1 - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice [lsearch -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list - if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { - tcl::dict::set opts $argname $choice - } else { - tcl::dict::set values_dict $argname $choice - } - } - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - set choice_ok [expr {$v_test in $choices_test}] - } - if {!$choice_ok} { - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs $argname - } - } - } + } + if {$is_strip_ansi} { - set stripped_list [lmap e $vlist {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach if {[tcl::dict::get $thisarg -multiple]} { if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { - tcl::dict::set opts $argname $stripped_list + tcl::dict::set opts $argname $stripped_list } else { tcl::dict::set values_dict $argname $stripped_list } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/assertion-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/assertion-0.1.0.tm index bee5a415..8ad0af62 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/assertion-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/assertion-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::assertion 0 0.1.0] +#[manpage_begin punkshell_module_punk::assertion 0 0.1.0] #[copyright "2024"] #[titledesc {assertion alternative to control::assert}] [comment {-- Name section and table of contents description --}] #[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/basictelnet-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/basictelnet-0.1.0.tm index 4a1df513..16debc6a 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/basictelnet-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/basictelnet-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,12 +18,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::basictelnet 0 0.1.0] +#[manpage_begin punkshell::basictelnet 0 0.1.0] #[copyright "2024"] #[titledesc {basic telnet client - DKF/Wiki}] [comment {-- Name section and table of contents description --}] #[moddesc {basic telnet client}] [comment {-- Description at end of page heading --}] #[require punk::basictelnet] -#[keywords module] +#[keywords module telnet protocol console terminal] #[description] #[para] see https://wiki.tcl-lang.org/page/Tcl+Telnet @@ -407,7 +407,7 @@ namespace eval punk::basictelnet { set RST "\x1b\[m" set debug_width 80 - set infoframe [textblock::frame -width $debug_width -ansiborder [a+ green bold] -title "[a cyan]Telnet Debug $terminal_type (encoding guess:$encoding_guess)$RST" $info] + set infoframe [textblock::frame -checkargs 0 -width $debug_width -ansiborder [a+ green bold] -title "[a cyan]Telnet Debug $terminal_type (encoding guess:$encoding_guess)$RST" $info] #set w [textblock::width $infoframe] set spacepatch "$RST[textblock::block $debug_width 4 { }]" #puts -nonewline [punk::ansi::cursor_off] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm index 9f07ec56..a8cdad9e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::blockletter 0 0.1.0] +#[manpage_begin punkshell_module_punk::blockletter 0 0.1.0] #[copyright "2024"] #[titledesc {punk::blockletter frame-based large lettering test/logo}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -299,10 +299,10 @@ tcl::namespace::eval punk::blockletter::lib { set h_in [expr {$h -2}] if {$w_in > 0 && $h_in > 0} { set inner [textblock::block $w_in $h_in \u00a0] ;#NBSP - textblock::frame -type $f -height $h -width $w -ansiborder [a+ $bd $bg] -ansibase [a+ $bg] $inner + textblock::frame -checkargs 0 -type $f -height $h -width $w -ansiborder [a+ $bd $bg] -ansibase [a+ $bg] $inner } else { #important to use no content arg - as empty string has 'height' of 1 in the textblock context (min height of any string is 1 row in the console) - textblock::frame -type $f -height $h -width $w -ansiborder [a+ $bd $bg] -ansibase [a+ $bg] + textblock::frame -checkargs 0 -type $f -height $h -width $w -ansiborder [a+ $bd $bg] -ansibase [a+ $bg] } } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/cesu-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/cesu-0.1.0.tm index 930513c6..3b8f0c87 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/cesu-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/cesu-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -19,7 +19,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::cesu 0 0.1.0] +#[manpage_begin punkshell_module_punk::cesu 0 0.1.0] #[copyright "2024"] #[titledesc {CESU compatibility ehcoding scheme for utf-16: 8-Bit (CESU-8) ??}] [comment {-- Name section and table of contents description --}] #[moddesc {CESU experimental}] [comment {-- Description at end of page heading --}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm index 001a7653..e3c188af 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm @@ -593,7 +593,13 @@ namespace eval punk::console { if {!$::punk::console::ansi_available} { return "" } - set callid [info cmdcount] ;#info cmdcount is almost as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context + # -- --- + #set callid [info cmdcount] ;#info cmdcount is fast, though not as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context + #clock clicks is approx 2x faster - but can sometimes give duplicates if called sequentially e.g list [clock clicks] [clock clicks] + #Either is suitable here, where subsequent calls will be relatively far apart in time + #speed of call insignificant compared to function + set callid [clock clicks] + # -- --- # upvar ::punk::console::ansi_response_chunk accumulator diff --git a/src/vfs/_vfscommon.vfs/modules/punk/docgen-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/docgen-0.1.0.tm index f4d26342..cea2d287 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/docgen-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/docgen-0.1.0.tm @@ -31,6 +31,7 @@ namespace eval punk::docgen { error "get_doctools_comments file '$fname' not found" } set fd [open $fname r] + chan conf $fd -translation binary set data [read $fd] close $fd if {![string match "*#\**!doctools*" $data]} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/experiment-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/experiment-0.1.0.tm index 9d9861f2..28f3166e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/experiment-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/experiment-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::experiment 0 0.1.0] +#[manpage_begin punkshell_module_punk::experiment 0 0.1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/island-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/island-0.1.0.tm index 7c843fef..59126a88 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/island-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/island-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -32,7 +32,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::island 0 0.1.0] +#[manpage_begin punkshell_module_punk::island 0 0.1.0] #[copyright "2024"] #[titledesc {filesystem islands for safe interps}] [comment {-- Name section and table of contents description --}] #[moddesc {punk::island for safe interps}] [comment {-- Description at end of page heading --}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm index 070621bc..da6de45d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm @@ -129,7 +129,7 @@ tcl::namespace::eval punk::lib::ensemble { list [tcl::namespace::which namespace] export *] while 1 { - set renamed ${routinens}::${routinetail}_[info cmdcount] + set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] if {[tcl::namespace::which $renamed] eq {}} break } @@ -147,6 +147,89 @@ tcl::namespace::eval punk::lib::ensemble { } } +# some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated +tcl::namespace::eval punk::lib::check { + proc has_tclbug_script_var {} { + + set script {set j [list spud] ; list} + append script \n + uplevel #0 $script + set rep1 [tcl::unsupported::representation $::j] + set script "" + set rep2 [tcl::unsupported::representation $::j] + + set nostring1 [string match "*no string" $rep1] + set nostring2 [string match "*no string" $rep2] + + #we assume it should have no string rep in either case + #Review: check Tcl versions for behaviour/consistency + if {!$nostring2} { + return true + } else { + return false + } + } + proc has_tclbug_lsearch_strideallinline {} { + #bug only occurs with single -index value combined with -stride -all -inline -subindices + #https://core.tcl-lang.org/tcl/tktview/5a1aaa201d + set result [lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *] + return [expr {$result ne "a2"}] + } + + proc has_tclbug_list_quoting_emptyjoin {} { + #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 + set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases + set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" + return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. + } + + proc has_tclbug_safeinterp_compile {{show 0}} { + #ensemble calls within safe interp not compiled + namespace eval [namespace current]::testcompile { + proc ensembletest {} {string index a 0} + } + + set has_bug 0 + + set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] + if {$show} { + puts outer: + puts $bytecode_outer + } + if {![interp issafe]} { + #test of safe subinterp only needed if we aren't already in a safe interp + if {![catch { + interp create x -safe + } errMsg]} { + x eval {proc ensembletest {} {string index a 0}} + set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] + if {$show} { + puts safe: + puts $bytecode_safe + } + interp delete x + #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) + #It's possible the interp we're running in is also not compiling ensembles. + #we could then get a result of 2 - which still indicates a problem + if {[string last "invokeStk" $bytecode_safe] >= 1} { + incr has_bug + } + } else { + #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? + #unlikely - but we should warn + puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" + } + } + + namespace delete [namespace current]::testcompile + + if {[string last "invokeStk" $bytecode_outer] >= 1} { + incr has_bug + } + return $has_bug + } +} + tcl::namespace::eval punk::lib::compat { #*** !doctools #[subsection {Namespace punk::lib::compat}] @@ -185,7 +268,7 @@ tcl::namespace::eval punk::lib::compat { return [lmap v $keep {lindex $v 1}] } #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. - #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 - and even in 8.7 it doesn't seem to allow returning one index of the stridden 'group' + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 if {"::lpop" ne [info commands ::lpop]} { #puts stderr "Warning - no built-in lpop" @@ -651,6 +734,180 @@ namespace eval punk::lib { } } + proc lzip {args} { + switch -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [lzip2lists {*}$args]} + 3 {return [lzip3lists {*}$args]} + 4 {return [lzip4lists {*}$args]} + 5 {return [lzip5lists {*}$args]} + 6 {return [lzip6lists {*}$args]} + 7 {return [lzip7lists {*}$args]} + 8 {return [lzip8lists {*}$args]} + 9 {return [lzip9lists {*}$args]} + 10 {return [lzip10lists {*}$args]} + 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } + default { + if {[llength $args] < 4000} { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } else { + return [lzipn {*}$args] + } + } + } + } + + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + puts "proc punk::lib::lzip${n}lists {$arglist} \{" + puts "$body" + puts "\}" + proc ::punk::lib::lzip${n}lists $arglist $body + } + + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } + + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} + } + + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + + if {[join $cur {}] == {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 + } + return $zip_l + } + #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible + if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { + #-stride either not available - or has bug preventing use of main algorithm below + proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + } else { + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + } + #experiment with equiv of js template literals with ${expression} in templates #e.g tstr {This is the value of x in calling scope ${$x} !} #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} @@ -2696,7 +2953,8 @@ namespace eval punk::lib { lappend opts -block {} } set text [lindex $args end] - tailcall linelist {*}$opts $text + #tailcall linelist {*}$opts $text + return [linelist {*}$opts $text] } #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds proc lines_as_list2 {args} { @@ -2714,9 +2972,8 @@ namespace eval punk::lib { # important for pipeline & match_assign # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace - set linelist_body { - set usage "linelist ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" if {[llength $args] == 0} { error "linelist missing textchunk argument usage:$usage" } @@ -2917,7 +3174,7 @@ namespace eval punk::lib { set replaycodes $RST ;#todo - default? set transformed [list] #shortcircuit common case of no ansi - #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the have backslash escapes due to Tcl list quoting and escaping behaviour. + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) @@ -2940,17 +3197,20 @@ namespace eval punk::lib { foreach ln $linelist { #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable - set ansisplits [punk::ansi::ta::split_codes_single $ln] - if {[llength $ansisplits]<= 1} { + #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + #get_codes_single lists only the codes. no plaintext or empty elements + set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits] == 0} { #plaintext only - no ansi codes in line lappend transformed [string cat $replaycodes $ln $RST] #leave replaycodes as is for next line set nextreplay $replaycodes } else { set tail $RST - set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + set lastcode [lindex $ansisplits end] ;#may or may not be SGR + set lastcodeoffset [expr {[string length $lastcode]-1}] if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { - if {[lindex $ansisplits end] eq ""} { + if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { #last plaintext is empty. So the line is already suffixed with a reset set tail "" set nextreplay $RST @@ -2960,7 +3220,8 @@ namespace eval punk::lib { set tail $RST set nextreplay $RST } - } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #code is at tail (no trailing plaintext) #No tail reset - and no need to examine whole line to determine stack that is in effect set tail $RST set nextreplay $lastcode @@ -2971,7 +3232,7 @@ namespace eval punk::lib { set tail $RST #determine effective replay for line set codestack [list start] - foreach {pt code} $ansisplits { + foreach code $ansisplits { if {[punk::ansi::codetype::is_sgr_reset $code]} { set codestack [list] ;#different from 'start' marked - this means we've had a reset } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { @@ -3043,89 +3304,418 @@ namespace eval punk::lib { #by putting in calls to punk::ansi the user will get appropriate error messages set linelist_body [string map { "package require punk::ansi"} $linelist_body] } - proc linelist {args} $linelist_body - - - interp alias {} errortime {} punk::lib::errortime - proc errortime {script groupsize {iters 2}} { - #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance - set i 0 - set times {} - if {$iters < 2} {set iters 2} - - for {set i 0} {$i < $iters} {incr i} { - set result [uplevel [list time $script $groupsize]] - lappend times [lindex $result 0] - } - - set average 0.0 - set s2 0.0 - - foreach time $times { - set average [expr {$average + double($time)/$iters}] - } - foreach time $times { - set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + set linelist_body_original { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? - set sigma [expr {int(sqrt($s2))}] - set average [expr int($average)] - - return "$average +/- $sigma microseconds per iteration" - } - - #test function to use with show_jump_tables - #todo - check if switch compilation to jump tables differs by Tcl version - proc switch_char_test {c} { - set dec [scan $c %c] - foreach t [list 1 2 3] { - switch -- $c { - x { - return [list $dec x $t] + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v } - y { - return [list $dec y $t] + default { + error "linelist: Unrecognized option '$o' usage:$usage" } - z { - return [list $dec z $t] + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } } } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + } + - #tcl 8.6/8.7 (at least) - #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable - switch -- $c { - a { - return [list $dec a] - } - {"} { - return [list $dec dquote] + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 } - {[} {return [list $dec lb]} - {]} {return [list $dec rb]} - "{" { - return [list $dec lbrace] + trimleft { + set tl_left 1 } - "}" { - return [list $dec rbrace] + trimright { + set tl_right 1 } default { - return [list $dec $c] + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" } - } - - - - } - - #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) - proc show_jump_tables {args} { - #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. - if {[llength $args] == 1} { - set data [tcl::unsupported::disassemble proc [lindex $args 0]] - } elseif {[llength $args] == 2} { - #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits]<= 1} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[lindex $ansisplits end] eq ""} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach {pt code} $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + proc linelist {args} $linelist_body + + + interp alias {} errortime {} punk::lib::errortime + proc errortime {script groupsize {iters 2}} { + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance + set i 0 + set times {} + if {$iters < 2} {set iters 2} + + for {set i 0} {$i < $iters} {incr i} { + set result [uplevel [list time $script $groupsize]] + lappend times [lindex $result 0] + } + + set average 0.0 + set s2 0.0 + + foreach time $times { + set average [expr {$average + double($time)/$iters}] + } + + foreach time $times { + set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + } + + set sigma [expr {int(sqrt($s2))}] + set average [expr int($average)] + + return "$average +/- $sigma microseconds per iteration" + } + + #test function to use with show_jump_tables + #todo - check if switch compilation to jump tables differs by Tcl version + proc switch_char_test {c} { + set dec [scan $c %c] + foreach t [list 1 2 3] { + switch -- $c { + x { + return [list $dec x $t] + } + y { + return [list $dec y $t] + } + z { + return [list $dec z $t] + } + } + } + + #tcl 8.6/8.7 (at least) + #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable + switch -- $c { + a { + return [list $dec a] + } + {"} { + return [list $dec dquote] + } + {[} {return [list $dec lb]} + {]} {return [list $dec rb]} + "{" { + return [list $dec lbrace] + } + "}" { + return [list $dec rbrace] + } + default { + return [list $dec $c] + } + } + + + + } + + #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) + proc show_jump_tables {args} { + #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. + if {[llength $args] == 1} { + set data [tcl::unsupported::disassemble proc [lindex $args 0]] + } elseif {[llength $args] == 2} { + #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. #not sure if this handles more complex hierarchies or mixins etc. lassign $args obj method if {![info object isa object $obj]} { @@ -3316,7 +3906,87 @@ namespace eval punk::lib { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::lib::flatgrid { + namespace export filler_count rows cols col row block + #WARNING - requires lseq and 'lsearch -stride' + #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 + #todo - 8.6 fallback? + + proc filler_count {listlen numcolumns} { + #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error + #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense + expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} + } + proc rows {list numcolumns {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set rows [list] + set i 1 + foreach s [lrange $splits 0 end-1] { + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + incr i + } + return $rows + } + proc cols {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] + } + return $cols + } + proc cols2 {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [col2 $list $numcolumns $colindex $blank] + } + return $cols + } + proc col {list numcolumns colindex {blank NULL}} { + lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * + } + proc col2 {list numcolumns colindex {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set col [list] + foreach s [lrange $splits 0 end-1] { + lappend col [lindex $padded_list $s+$colindex] + } + return $col + } + proc col3 {list numcolumns colindex {blank NULL}} { + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} + } + proc col4 {list numcolumns colindex {blank NULL}} { + #slow + set vars [lrepeat $numcolumns _] + lset vars $colindex v + if {$blank eq ""} { + return [lmap $vars $list {set v}] + } + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} + } + + proc block {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } + proc block2 {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols2 $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } +} @@ -3330,78 +4000,6 @@ tcl::namespace::eval punk::lib::system { #[para] Internal functions that are not part of the API #[list_begin definitions] - proc has_tclbug_script_var {} { - set script {set j [list spud] ; list} - append script \n - uplevel #0 $script - set rep1 [tcl::unsupported::representation $::j] - set script "" - set rep2 [tcl::unsupported::representation $::j] - - set nostring1 [string match "*no string" $rep1] - set nostring2 [string match "*no string" $rep2] - - #we assume it should have no string rep in either case - #Review: check Tcl versions for behaviour/consistency - if {!$nostring2} { - return true - } else { - return false - } - } - - proc has_tclbug_list_quoting_emptyjoin {} { - #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 - set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases - set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" - return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. - } - - proc has_tclbug_safeinterp_compile {{show 0}} { - #ensemble calls within safe interp not compiled - namespace eval [namespace current]::testcompile { - proc ensembletest {} {string index a 0} - } - - set has_bug 0 - - set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] - if {$show} { - puts outer: - puts $bytecode_outer - } - if {![interp issafe]} { - #test of safe subinterp only needed if we aren't already in a safe interp - if {![catch { - interp create x -safe - } errMsg]} { - x eval {proc ensembletest {} {string index a 0}} - set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] - if {$show} { - puts safe: - puts $bytecode_safe - } - interp delete x - #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) - #It's possible the interp we're running in is also not compiling ensembles. - #we could then get a result of 2 - which still indicates a problem - if {[string last "invokeStk" $bytecode_safe] >= 1} { - incr has_bug - } - } else { - #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? - #unlikely - but we should warn - puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" - } - } - - namespace delete [namespace current]::testcompile - - if {[string last "invokeStk" $bytecode_outer] >= 1} { - incr has_bug - } - return $has_bug - } proc mostFactorsBelow {n} { ##*** !doctools diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.0.tm index 1d8d40e1..8d68b28a 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.0.tm @@ -48,6 +48,7 @@ namespace eval punk::mix::commandset::doc { set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man] foreach maybedoomed $oldfiles { set fd [open $maybedoomed r] + chan conf $fd -translation binary set data [read $fd] close $fd if {[string match "*--- punk::docgen overwrites *" $data]} { @@ -170,7 +171,7 @@ namespace eval punk::mix::commandset::doc { -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 *values -min 0 -max -1 - patterns -default {*} -type any -multiple 1 + patterns -default {*.man} -type any -multiple 1 } $args] set opt_individual [tcl::dict::get $argd opts -individual] set patterns [tcl::dict::get $argd values patterns] @@ -190,7 +191,7 @@ namespace eval punk::mix::commandset::doc { set docroot $projectdir/src/doc cd $docroot - if {!$opt_individual && "*" in $patterns} { + if {!$opt_individual && "*.man" in $patterns} { if {[catch { dtplite validate $docroot } errM]} { @@ -251,6 +252,7 @@ namespace eval punk::mix::commandset::doc { append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n foreach fullpath $matched_paths { + puts stdout "do_docgen processing: $fullpath" set doctools [punk::docgen::get_doctools_comments $fullpath] if {$doctools ne ""} { set fname [file tail $fullpath] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index c61db428..65a9fb77 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -1,5 +1,5 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev make' or src/make.tcl to update from -buildversion.txt # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -13,19 +13,70 @@ # @@ Meta End +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_scriptwrap 0 0.1.0] +#[copyright "2024"] +#[titledesc {scriptwrap polyglot tool}] [comment {-- Name section and table of contents description --}] +#[moddesc {scriptwrap tool}] [comment {-- Description at end of page heading --}] +#[require punk::mix::commandset::scriptwrap] +#[keywords module commandset launcher scriptwrap] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of scriptwrap +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by poshinfo +#[list_begin itemized] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements ##e.g package require frobz +package require punk::lib +package require punk::args package require punk::mix package require punk::mix::base package require punk::fileline +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::lib}] +#[item] [package {punk::args}] +#[item] [package {punk::mix}] +#[item] [package {punk::base}] +#[item] [package {punk::fileline}] + +#*** !doctools +#[list_end] + +#*** !doctools +#[section API] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + namespace eval punk::mix::commandset::scriptwrap { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::scriptwrap}] + #[para] Core API functions for punk::mix::commandset::scriptwrap + #[list_begin definitions] + namespace export * namespace eval fileline { @@ -1192,22 +1243,33 @@ namespace eval punk::mix::commandset::scriptwrap { return $result } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap ---}] namespace eval lib { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] + #[para] Library API functions for punk::mix::commandset::scriptwrap + #[list_begin definitions] proc get_wrapper_folders {args} { set argd [punk::args::get_dict { #*** !doctools #[call [fun get_wrapper_folders] [arg args] ] - #[para] Return list of dicts representing wrapper folders. keys: basefolder sourceinfo + #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo #[para] Arguments: # [list_begin arguments] # [arg_def string args] name-value pairs -scriptpath # [list_end] - *proc -name get_wrapper_folders + *id punk::mix::commandset::scriptwrap + *proc -name punk::mix::commandset::get_wrapper_folders + *opts -anyopts 0 - -scriptpath -default "" + -scriptpath -default "" -type directory\ + -help "" + #todo -help folder within a punk.templates provided area??? + *values -minvalues 0 -maxvalues 0 } $args] @@ -1377,11 +1439,16 @@ namespace eval punk::mix::commandset::scriptwrap { return [dict create ok $status linecount [llength $lines] data $tags errors $errors] } - + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap::lib ---}] } namespace eval batchlib { - # + #*** !doctools + #[subsection {Namespace punk::mix::commandset::scriptwrap::batchlib}] + #[para] Utility funcions for processing windows .bat files + #[list_begin definitions] + #see also: https://www.dostips.com/forum/viewtopic.php?t=3803 'Rules for label names vs GOTO and CALL # review - we may need different get_callsite_label functions? @@ -1647,23 +1714,13 @@ namespace eval punk::mix::commandset::scriptwrap { #return rawlabel so we can see it as it appears in the data - as opposed to how it is interpreted as a label by cmd.exe return [list labelfound 1 label $label rawlabel $rawlabel] } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap::batchlib ---}] } } - - - - - - - - - - - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::commandset::scriptwrap { @@ -1671,3 +1728,6 @@ package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::com set version 0.1.0 }] return + +#*** !doctools +#[manpage_end] \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm index 9cf44529..9bf5a060 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm @@ -20,10 +20,10 @@ #*** !doctools #[manpage_begin shellspy_module_punk::nav::fs 0 0.1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[titledesc {punk::nav::fs console filesystem navigation}] [comment {-- Name section and table of contents description --}] +#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] #[require punk::nav::fs] -#[keywords module] +#[keywords module filesystem terminal] #[description] #[para] - @@ -936,7 +936,7 @@ tcl::namespace::eval punk::nav::fs { #windows doesn't consider dotfiles as hidden - mac does (?) #we add dotfiles to flaggedhidden list in case there is some other mechanism that has flagged items as hidden if {$::tcl_platform(platform) ne "windows"} { - lappend flaggedhidden {*}[lsearch -all -inline [concat $dirs $files] ".*"] + lappend flaggedhidden {*}[lsearch -all -inline [list {*}$dirs {*}$files] ".*"] #e.g we can have dupes in the case where there are vfs mounted files that appear as dirs #as we will need to do a (nat)sort as a last step - it will be faster to not sort items prematurely #set flaggedhidden [lsort -unique $flaggedhidden] @@ -977,7 +977,8 @@ tcl::namespace::eval punk::nav::fs { # -- --- - foreach nm [concat $dirs $files] { + #jmn + foreach nm [list {*}$dirs {*}$files] { if {[punk::winpath::illegalname_test $nm]} { lappend nonportable $nm } @@ -1272,7 +1273,8 @@ tcl::namespace::eval punk::nav::fs { #set widest1 [punk::pipedata [list {*}$dirs ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] - set widest1 [tcl::mathfunc::max {*}[lmap v [concat $dirs [list ""]] {string length $v}]] + #set widest1 [tcl::mathfunc::max {*}[lmap v [concat $dirs [list ""]] {string length $v}]] + set widest1 [tcl::mathfunc::max {*}[lmap v [list {*}$dirs ""] {string length $v}]] set displaylist [list] set col1 [string repeat " " [expr {$widest1 + 2}]] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm index 10250a9b..b9dc3707 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm @@ -755,7 +755,9 @@ tcl::namespace::eval punk::ns { set seencmds [list] set masked [list] ;# - set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] + #jmn + #set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] + set cmdsets [list {*}$procs {*}$ensembles {*}$ooclasses {*}$ooobjects {*}$ooprivateobjects {*}$ooprivateclasses {*}$native {*}$interps {*}$coroutines {*}$zlibstreams] foreach a $aliases { if {[list c $a] in $elements} { #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo @@ -1691,7 +1693,8 @@ tcl::namespace::eval punk::ns { proc _pkguse_vars {varnames} { while {"pkguse_vars_[incr n]" in $varnames} {} - return [concat $varnames pkguse_vars_$n] + #return [concat $varnames pkguse_vars_$n] + return [list {*}$varnames pkguse_vars_$n] } proc tracehandler_nowrite {args} { error "readonly in use block" diff --git a/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm index e38c76c6..54949ad4 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm @@ -1,5 +1,5 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# 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. @@ -18,12 +18,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::packagepreference 0 0.1.0] +#[manpage_begin punkshell_module_punk::packagepreference 0 0.1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] +#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] #[require punk::packagepreference] -#[keywords module] +#[keywords module package] #[description] #[para] - diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm index a425946f..b8f0c1dd 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm @@ -898,7 +898,7 @@ namespace eval punk::repl::class { append debug \n $mergedinfo append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $new0] before row:$o_cursor_row after row: $result_row before col:$o_cursor_col after col:$result_col" package require textblock - set debug [textblock::frame -buildcache 0 $debug] + set debug [textblock::frame -checkargs 0 -buildcache 0 $debug] catch {punk::console::move_emitblock_return $debug_first_row 1 $debug} # -- --- --- --- --- --- @@ -962,7 +962,7 @@ namespace eval punk::repl::class { set debug "add_chunk$i" append debug \n $mergedinfo append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $p]" - set debug [textblock::frame -buildcache 0 $debug] + set debug [textblock::frame -checkargs 0 -buildcache 0 $debug] #catch {punk::console::move_emitblock_return [expr {$debug_first_row + ($i * 6)}] 1 $debug} set result [dict get $mergedinfo result] @@ -1033,7 +1033,9 @@ namespace eval punk::repl::class { #todo #each newpart needs its grapheme split info to be stored - set o_rendered_lines [concat $o_rendered_lines [lrange $newparts 1 end]] + #jmn + #set o_rendered_lines [concat $o_rendered_lines [lrange $newparts 1 end]] + lappend o_rendered_lines {*}[lrange $newparts 1 end] } method linecount {} { @@ -1565,11 +1567,11 @@ proc punk::repl::console_debugview {editbuf consolewidth args} { } set debug_height [expr {[llength $lines]+2}] ;#framed height } errM]} { - set info [textblock::frame -buildcache 0 -title "[a red]error$RST" $errM] + set info [textblock::frame -checkargs 0 -buildcache 0 -title "[a red]error$RST" $errM] set debug_height [textblock::height $info] } else { #treat as ephemeral (unreusable) frames due to varying width & height - therefore set -buildcache 0 - set info [textblock::frame -buildcache 0 -ansiborder [a+ bold green] -title "[a cyan]debugview_raw$RST" $info] + set info [textblock::frame -checkargs 0 -buildcache 0 -ansiborder [a+ bold green] -title "[a cyan]debugview_raw$RST" $info] } set debug_width [textblock::widthtopline $info] @@ -1604,14 +1606,14 @@ proc punk::repl::console_editbufview {editbuf consolewidth args} { set info [punk::lib::list_as_lines $lines] } } editbuf_error]} { - set info [textblock::frame -buildcache 0 -title "[a red]error[a]" "$editbuf_error\n$::errorInfo"] + set info [textblock::frame -checkargs 0 -buildcache 0 -title "[a red]error[a]" "$editbuf_error\n$::errorInfo"] } else { set title "[a cyan]editbuf [expr {[llength $editbuf_list]-1}] lines [$editbuf linecount][a]" append title "[a+ yellow bold] col:[format %3s [$editbuf cursor_column]] row:[$editbuf cursor_row][a]" set row1 " lastchar:[ansistring VIEW -lf 1 [$editbuf last_char]] lastgrapheme:[ansistring VIEW -lf 1 [$editbuf last_grapheme]]" set row2 " lastansi:[ansistring VIEW -lf 1 [$editbuf last_ansi]]" set info [a+ green bold]$row1\n$row2[a]\n$info - set info [textblock::frame -buildcache 0 -ansiborder [a+ green bold] -title $title $info] + set info [textblock::frame -checkargs 0 -buildcache 0 -ansiborder [a+ green bold] -title $title $info] } set editbuf_width [textblock::widthtopline $info] set spacepatch [textblock::block $editbuf_width 2 " "] @@ -1635,7 +1637,7 @@ proc punk::repl::console_controlnotification {message consolewidth consoleheight set message [lindex $messagelines 0] ;#only allow single line set info "[a+ bold red]$message[a]" set hlt [dict get [textblock::framedef light] hlt] - set box [textblock::frame -boxmap [list tlc $hlt trc $hlt] -title $message -height 1] + set box [textblock::frame -checkargs 0 -boxmap [list tlc $hlt trc $hlt] -title $message -height 1] set notification_width [textblock::widthtopline $info] set box_offset [expr {$consolewidth - $notification_width - $opt_rightmargin}] set row [expr {$consoleheight - $opt_bottommargin}] @@ -2155,7 +2157,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #----------------------------------------- #list/string-rep bug workaround part 2 - #todo - set flag based on punk::lib::system::has_tclbug_script_var + #todo - set flag based on punk::lib::check::has_tclbug_script_var lappend run_command_cache $run_command_string #puts stderr "run_command_string rep: [rep $run_command_string]" if {[llength $run_command_cache] > 2000} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm index bc93a9c3..db0911f4 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm @@ -710,7 +710,7 @@ namespace eval punk::repo { lappend col2_values [dict get $summary_dict $f] } set title1 "" - set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_fields] {string length $v}]] + set widest1 [tcl::mathfunc::max {*}[lmap v [list $title1 {*}$col1_fields] {string length $v}]] set col1 [string repeat " " $widest1] set title2 "" set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2_values] {string length $v}]] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/rest-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/rest-0.1.0.tm index 2198f2c6..93f27599 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/rest-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/rest-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -19,7 +19,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::rest 0 0.1.0] +#[manpage_begin punkshell_module_punk::rest 0 0.1.0] #[copyright "2024"] #[titledesc {punk::rest}] [comment {-- Name section and table of contents description --}] #[moddesc {experimental rest}] [comment {-- Description at end of page heading --}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/sshrun-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/sshrun-0.1.0.tm index 282694b3..1b91629b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/sshrun-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/sshrun-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # (C) 2009 Jose F. Nieves @@ -30,7 +30,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::sshrun 0 0.1.0] +#[manpage_begin punkshell_module_punk::sshrun 0 0.1.0] #[copyright "2009"] #[titledesc {Tcl procedures to execute tcl scripts in remote hosts}] [comment {-- Name section and table of contents description --}] #[moddesc {punk::sshrun tclssh clone}] [comment {-- Description at end of page heading --}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/trie-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/trie-0.1.0.tm index 6f7f9d14..0b5bd298 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/trie-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/trie-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::trie 0 0.1.0] +#[manpage_begin punkshell_module_punk::trie 0 0.1.0] #[copyright "2010"] #[titledesc {punk::trie API}] [comment {-- Name section and table of contents description --}] #[moddesc {punk::trie}] [comment {-- Description at end of page heading --}] @@ -64,34 +64,34 @@ package require Tcl 8.6- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::trie::class { - #*** !doctools - #[subsection {Namespace punk::trie::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 ---}] - #} -#} +# #tcl::namespace::eval punk::trie::class { +# #*** !doctools +# #[subsection {Namespace punk::trie::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 ---}] +# #} +# #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -114,11 +114,18 @@ tcl::namespace::eval punk::trie { } #namespace path ::punk::trie::log - #[para] class definitions + #*** !doctools + #[subsection {Namespace punk::trie}] + #[para] Core API functions for punk::trie if {[tcl::info::commands [tcl::namespace::current]::trieclass] eq ""} { #*** !doctools #[list_begin enumerated] + oo::class create [tcl::namespace::current]::trieclass { + #*** !doctools + #[enum] CLASS [class trieclass] + #[list_begin definitions] + variable trie id method matches {t what} { @@ -412,9 +419,8 @@ tcl::namespace::eval punk::trie { } set acc {} - - foreach key [dict keys $t] { - lappend acc {*}[my flatten [dict get $t $key] $prefix$key] + dict for {key val} $t { + lappend acc {*}[my flatten $val $prefix$key] } return $acc } @@ -484,8 +490,14 @@ tcl::namespace::eval punk::trie { my insert $a } } + + #*** !doctools + #[list_end] [comment {--- end definitions ---}] } + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + set testlist [list blah x black blacken] proc test1 {} { #JMN @@ -516,14 +528,9 @@ tcl::namespace::eval punk::trie { # #[list_end] [comment {-- end definitions interface_sample1}] # } - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] } - #*** !doctools - #[subsection {Namespace punk::trie}] - #[para] Core API functions for punk::trie - #[list_begin definitions] + @@ -542,8 +549,6 @@ tcl::namespace::eval punk::trie { - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::trie ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/uc-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/uc-0.1.0.tm index 610de187..6c143b29 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/uc-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/uc-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,12 +18,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::uc 0 0.1.0] +#[manpage_begin punkshell_module_punk::uc 0 0.1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::uc] -#[keywords module] +#[keywords module unofficial unicode wcswidth] #[description] #[para] - @@ -35022,7 +35022,9 @@ namespace eval punk::uc::lib { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Internal] + namespace eval punk::uc::system { + #*** !doctools #[subsection {Namespace punk::uc::system}] #[para] Internal functions that are not part of the API diff --git a/src/vfs/_vfscommon.vfs/modules/punk/winlnk-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/winlnk-0.1.0.tm index 83684385..918d380d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/winlnk-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/winlnk-0.1.0.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::winlnk 0 0.1.0] +#[manpage_begin punkshell_module_punk::winlnk 0 0.1.0] #[copyright "2024"] #[titledesc {windows shortcut .lnk library}] [comment {-- Name section and table of contents description --}] #[moddesc {punk::winlnk}] [comment {-- Description at end of page heading --}] @@ -34,7 +34,7 @@ #[para] overview of punk::winlnk #[subsection Concepts] #[para] Windows shortcuts are a binary format file with a .lnk extension -#[para] Shell Link (.LNK) Binary File Format is documented in [MS_SHLLINK].pdf published by Microsoft. +#[para] Shell Link (.LNK) Binary File Format is documented in [lb]MS_SHLLINK[rb].pdf published by Microsoft. #[para] Revision 8.0 published 2024-04-23 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm index 2dc235ed..311a8025 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm @@ -1,6 +1,6 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/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. @@ -11,7 +11,7 @@ # @@ Meta Begin # Application punk::zip 0.1.1 # Meta platform tcl -# Meta license +# Meta license MIT # @@ Meta End @@ -19,12 +19,12 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::zip 0 0.1.1] +#[manpage_begin punkshell_module_punk::zip 0 0.1.1] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::zip] -#[keywords module] +#[keywords module zip fileformat] #[description] #[para] - @@ -60,38 +60,6 @@ package require punk::args #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::zip::class { - #*** !doctools - #[subsection {Namespace punk::zip::class}] - #[para] class definitions - #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace @@ -541,37 +509,60 @@ tcl::namespace::eval punk::zip { #todo - doctools - [arg ?globs...?] syntax? #*** !doctools - #[call [fun mkzip] [arg ?options?] [arg filename] ] - #[para] Create a zip archive in 'filename' + #[call [fun mkzip]\ + # [opt "[option -offsettype] [arg offsettype]"]\ + # [opt "[option -return] [arg returntype]"]\ + # [opt "[option -zipkit] [arg 0|1]"]\ + # [opt "[option -runtime] [arg preamble_filename]"]\ + # [opt "[option -comment] [arg zipfilecomment]"]\ + # [opt "[option -directory] [arg dir_to_zip]"]\ + # [opt "[option -base] [arg archive_root]"]\ + # [opt "[option -exclude] [arg globlist]"]\ + # [arg zipfilename]\ + # [arg ?glob...?]] + #[para] Create a zip archive in 'zipfilename' #[para] If a file already exists, an error will be raised. + #[para] Call 'punk::zip::mkzip' with no arguments for usage display. + set argd [punk::args::get_dict { - *proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" + *proc -name punk::zip::mkzip\ + -help "Create a zip archive in 'filename'" *opts - -offsettype -default "archive" -choices {archive file} -help "zip offsets stored relative to start of entire file or relative to start of zip-archive + -offsettype -default "archive" -choices {archive file}\ + -help "zip offsets stored relative to start of entire file or relative to start of zip-archive Only relevant if the created file has a script/runtime prefix. " - -return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive - the option -return pretty is the default and uses the punk::lib pdict/plist system - to return a formatted list for the terminal - " - -zipkit -default 0 -type none -help "whether to add mounting script - mutually exclusive with -runtime option - currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs + -return -default "pretty" -choices {pretty list none}\ + -help "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal " - -runtime -default "" -help "specify a prefix file - e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip - will create a self-extracting zip archive from the subdir/ folder. - Expects runtime with no existing vfs attached (review) + -zipkit -default 0 -type none\ + -help "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs " - -comment -default "" -help "An optional comment for the archive" - -directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" - -base -default "" -help "The new zip archive will be rooted in this directory if provided - it must be a parent of -directory or the same path as -directory" + -runtime -default ""\ + -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review) + " + -comment -default ""\ + -help "An optional comment for the archive" + -directory -default ""\ + -help "The new zip archive will scan for contents within this folder or current directory if not provided." + -base -default ""\ + -help "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory or the same path as -directory" -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + *values -min 1 -max -1 - filename -type file -default "" -help "name of zipfile to create" - globs -default {*} -multiple 1 -help "list of glob patterns to match. - Only directories with matching files will be included in the archive" + filename -type file -default ""\ + -help "name of zipfile to create" + globs -default {*} -multiple 1\ + -help "list of glob patterns to match. + Only directories with matching files will be included in the archive." } $args] set filename [dict get $argd values filename] @@ -733,7 +724,7 @@ tcl::namespace::eval punk::zip { } set cdoffset [tell $zf] set endrec [binary format a4ssssiis PK\05\06 0 0 \ - $count $count [string length $cd] $cdoffset\ + $count $count [string length $cd] [expr {$cdoffset - $dataStartOffset}]\ [string length $opts(-comment)]] append endrec $opts(-comment) puts -nonewline $zf $cd @@ -793,17 +784,6 @@ tcl::namespace::eval punk::zip::lib { -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval punk::zip::system { - #*** !doctools - #[subsection {Namespace punk::zip::system}] - #[para] Internal functions that are not part of the API - - - -#} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::zip [tcl::namespace::eval punk::zip { diff --git a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm index 8d24e650..2419f9fb 100644 --- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm @@ -21,7 +21,7 @@ #[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] #[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] #[require textblock] -#[keywords module utility lib] +#[keywords module ansi text layout colour table frame console terminal] #[description] #[para] Ansi-aware terminal textblock manipulation @@ -180,7 +180,7 @@ tcl::namespace::eval textblock { variable table_edge_parts set table_edge_parts [tcl::dict::create\ topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ + topinner [struct::set intersect $C $tops]\ topright [struct::set intersect $O [concat $tops $rights]]\ topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ middleleft [struct::set intersect $L $lefts]\ @@ -201,22 +201,22 @@ tcl::namespace::eval textblock { #The usual-case of a single header line is the 'onlyleft,onlyinner,onlyright,onlysolo' set. variable header_edge_parts set header_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ + topleft [struct::set intersect $C [list {*}$tops {*}$lefts]]\ + topinner [struct::set intersect $C $tops]\ + topright [struct::set intersect $O [list {*}$tops {*}$rights]]\ + topsolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ middleleft [struct::set intersect $L $lefts]\ middleinner [list]\ middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts]]\ + middlesolo [struct::set intersect $U [list {*}$lefts {*}$rights]]\ + bottomleft [struct::set intersect $L $lefts]\ bottominner [list]\ bottomright [struct::set intersect $U $rights]\ - bottomsolo [struct::set intersect $U [concat $lefts $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts]]\ + bottomsolo [struct::set intersect $U [list {*}$lefts {*}$rights]]\ + onlyleft [struct::set intersect $C [list {*}$tops {*}$lefts]]\ onlyinner [struct::set intersect $C $tops]\ - onlyright [struct::set intersect $O [concat $tops $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $rights]]\ + onlyright [struct::set intersect $O [list {*}$tops {*}$rights]]\ + onlysolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ ] variable table_hseps set table_hseps [tcl::dict::create\ @@ -321,9 +321,17 @@ tcl::namespace::eval textblock { set switch_keys_valid_copts [lrange $switch_keys_valid_copts 0 end-1] oo::class create [tcl::namespace::current]::table [tcl::string::map [list %topt_keys% $topt_keys %topt_switchkeys% $switch_keys_valid_topts %copt_keys% $copt_keys %copt_switchkeys% $switch_keys_valid_copts] { + #*** !doctools #[enum] CLASS [class textblock::class::table] #[list_begin definitions] + #[para] Create a table suitable for terminal output with various border styles. + #[para] The table can contain multiline cells and ANSI colour and text style attributes. + #[para] Multiple header rows can be configured. + #[para] Header rows can span columns - data rows cannot. + #[para] The restriction on data rows is to maintain compatibility of the data with a Tcl matrix command + #[para] (see get_matrix command) + #[para] Both header and data cells can have various text and blockalignments configured. # [para] [emph METHODS] variable o_opts_table ;#options as configured by user (with exception of -ansireset) variable o_opts_table_effective; #options in effect - e.g with defaults merged in. @@ -348,6 +356,8 @@ tcl::namespace::eval textblock { constructor {args} { #*** !doctools #[call class::table [method constructor] [arg args]] + #[para] TODO - document the many options + set o_opts_table_defaults $::textblock::class::opts_table_defaults set o_opts_column_defaults $::textblock::class::opts_column_defaults @@ -452,6 +462,22 @@ tcl::namespace::eval textblock { set ft_body light } } + light_b { + if {$requested_ft_header eq ""} { + set ft_header heavy_b + } + if {$requested_ft_body eq ""} { + set ft_body light_b + } + } + light_c { + if {$requested_ft_header eq ""} { + set ft_header heavy_c + } + if {$requested_ft_body eq ""} { + set ft_body light_c + } + } default { if {$requested_ft_header eq ""} { set ft_header $requested_ft @@ -525,6 +551,10 @@ tcl::namespace::eval textblock { return [tcl::dict::create body $blims header $hlims] } method configure args { + #*** !doctools + #[call class::table [method configure] [arg args]] + #[para] get or set various table-level properties + if {![llength $args]} { return $o_opts_table } @@ -744,6 +774,11 @@ tcl::namespace::eval textblock { #integrate with struct::matrix - allows ::m format 2string $table method printmatrix {matrix} { + #*** !doctools + #[call class::table [method printmatrix] [arg matrix]] + #[para] clear all table rows and print a matrix into the table + #[para] The rowxcolumn structure must match + set matrix_rowcount [$matrix rows] set matrix_colcount [$matrix columns] set table_colcount [my column_count] @@ -765,6 +800,10 @@ tcl::namespace::eval textblock { my print } method as_matrix {{cmd ""}} { + #*** !doctools + #[call class::table [method as_matrix] [arg ?cmd?]] + #[para] return a struct::matrix command representing the data portion of the table. + if {$cmd eq ""} { set m [struct::matrix] } else { @@ -832,9 +871,16 @@ tcl::namespace::eval textblock { return $colcount } method column_count {} { + #*** !doctools + #[call class::table [method column_count]] + #[para] return the number of columns return [tcl::dict::size $o_columndefs] } method configure_column {index_expression args} { + #*** !doctools + #[call class::table [method configure_column] [arg index_expression] [arg args]] + #[para] - undocumented + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" @@ -1055,6 +1101,9 @@ tcl::namespace::eval textblock { } method header_count {} { + #*** !doctools + #[call class::table [method header_count]] + #[para] return the number of header rows return [tcl::dict::size $o_headerstates] } method header_count_calc {} { @@ -1066,6 +1115,10 @@ tcl::namespace::eval textblock { return $max_headers } method header_height {header_index} { + #*** !doctools + #[call class::table [method header_height] [arg header_index]] + #[para] return the height of a header as the number of content-lines + set idx [lindex [tcl::dict::keys $o_headerstates $header_index]] return [tcl::dict::get $o_headerstates $idx maxheightseen] } @@ -1097,6 +1150,10 @@ tcl::namespace::eval textblock { # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} # method header_colspans {} { + #*** !doctools + #[call class::table [method header_colspans]] + #[para] Show the colspans configured for all headers + #set num_headers [my header_count_calc] set num_headers [my header_count] set colspans_by_header [tcl::dict::create] @@ -1177,6 +1234,10 @@ tcl::namespace::eval textblock { #should be configure_headerrow ? method configure_header {index_expression args} { + #*** !doctools + #[call class::table [method configure_header]] + #[para] - undocumented + #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis #e.g o_headerstates: 0 {maxheightseen 1} 1 {maxheightseen 2} @@ -1448,7 +1509,12 @@ tcl::namespace::eval textblock { method add_row {valuelist args} { #*** !doctools - #[call class::table [method add_row] [arg args]] + #[call class::table [method add_row]\ + # [arg valuelist]\ + # [opt "[option -minheight] [arg int_minheight]"]\ + # [opt "[option -maxheight] [arg int_maxheight]"]\ + # [opt "[option -ansibase] [arg ansicode]"]\ + #] if {[tcl::dict::size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [tcl::dict::size $o_columndefs])} { set msg "" append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [tcl::dict::size $o_columndefs]" \n @@ -1523,16 +1589,15 @@ tcl::namespace::eval textblock { set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] tcl::dict::lappend o_columndata $c $v - set valheight [textblock::height $v] + lassign [textblock::size_as_list $v] valwidth valheight if {$valheight > $max_height_seen} { set max_height_seen $valheight } - set width [textblock::width $v] - if {$width > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { - tcl::dict::set o_columnstates $c maxwidthbodyseen $width + if {$valwidth > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { + tcl::dict::set o_columnstates $c maxwidthbodyseen $valwidth } - if {$width < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { - tcl::dict::set o_columnstates $c minwidthbodyseen $width + if {$valwidth < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { + tcl::dict::set o_columnstates $c minwidthbodyseen $valwidth } if {[tcl::dict::get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [tcl::dict::get $o_columnstates $c minwidthbodyseen] < $prev_minwidth} { @@ -1552,6 +1617,13 @@ tcl::namespace::eval textblock { return $rowcount } method configure_row {index_expression args} { + #*** !doctools + #[call class::table [method configure_row]\ + # [arg index_expression]\ + # [opt "[option -minheight] [arg int_minheight]"]\ + # [opt "[option -maxheight] [arg int_maxheight]"]\ + # [opt "[option -ansibase] [arg ansicode]"]\ + #] set ridx [lindex [tcl::dict::keys $o_rowdefs] $index_expression] if {$ridx eq ""} { error "textblock::table::configure_row - no row defined at index '$ridx'.Use add_row to define rows" @@ -1640,9 +1712,16 @@ tcl::namespace::eval textblock { tcl::dict::set o_rowdefs $ridx $opts } method row_count {} { + #*** !doctools + #[call class::table [method row_count]] + #[para] return the number of data rows in the table. return [tcl::dict::size $o_rowdefs] } method row_clear {} { + #*** !doctools + #[call class::table [method row_clear]] + #[para] Remove all rows without resetting column data. + #[para] When adding new rows the number of entries will need to match the existing column count. set o_rowdefs [tcl::dict::create] set o_rowstates [tcl::dict::create] #The data values are stored by column regardless of whether added row by row @@ -1655,6 +1734,12 @@ tcl::namespace::eval textblock { set o_calculated_column_widths [list] } method clear {} { + #*** !doctools + #[call class::table [method clear]] + #[para] Remove all row and column data. + #[para] If a subsequent call to add_row is made it can contain any number of values. + #[para] Further calls to add_row will need to contain the same number of values + #[para] as the first call unless default values have been set for the missing columns (review - in flux). my row_clear set o_columndefs [tcl::dict::create] set o_columndata [tcl::dict::create] @@ -2000,7 +2085,7 @@ tcl::namespace::eval textblock { #just write an empty vertical placeholder. The spanned value will be overtyped below set cellcontents [::join [lrepeat [llength [split $hval \n]] ""] \n] } - set header_cell_startspan [textblock::frame -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ + set header_cell_startspan [textblock::frame -checkargs 0 -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ -ansibase $ansibase_header -ansiborder $ansiborder_final\ -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ ] @@ -2134,7 +2219,7 @@ tcl::namespace::eval textblock { #set spacemap [list hl * vl * tlc * blc * trc * brc *] #-usecache 1 ok #hval is not raw headerval - it has been padded to required width and has ansi applied - set hblock [textblock::frame -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase + set hblock [textblock::frame -checkargs 0 -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase #puts "==>boxlimits:'$hlims' hval_width:[tcl::string::length $hval] blockwidth:[textblock::width $hblock]" #puts $hblock #puts "==>hval:'$hval'[a]" @@ -2199,7 +2284,7 @@ tcl::namespace::eval textblock { # -usecache 1 ok #frame borders will never display - so use the simplest frametype and don't apply any ansi #puts "===>zerospan hlims: $hlims" - set header_frame [textblock::frame -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ + set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ ] } @@ -2220,7 +2305,7 @@ tcl::namespace::eval textblock { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts only$opt_posn] ] } set header_joins $header_body_joins - set header_frame [textblock::frame -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ + set header_frame [textblock::frame -checkargs 0 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ -ansibase $ansibase_header -ansiborder $ansiborder_final\ -boxlimits $hlims -boxmap $hdrmap -joins $header_joins\ ] @@ -2366,7 +2451,7 @@ tcl::namespace::eval textblock { set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] } } - set rowframe [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] + set rowframe [textblock::frame -checkargs 0 -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] set return_bodywidth [textblock::widthtopline $rowframe] ;#frame lines always same width - just look at top line append part_body $rowframe \n } else { @@ -2384,7 +2469,7 @@ tcl::namespace::eval textblock { set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] } } - append part_body [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n + append part_body [textblock::frame -checkargs 0 -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n } incr r } @@ -2411,7 +2496,7 @@ tcl::namespace::eval textblock { append part_body [tcl::string::repeat " " $colwidth] \n set return_bodywidth $colwidth } else { - set emptyframe [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] + set emptyframe [textblock::frame -checkargs 0 -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] append part_body $emptyframe \n set return_bodywidth [textblock::width $emptyframe] } @@ -2441,6 +2526,10 @@ tcl::namespace::eval textblock { } method get_column_cells_by_index {index_expression} { + #*** !doctools + #[call class::table [method get_column_cells_by_index] [arg index_expression]] + #[para] Return a dict with keys 'headers' and 'cells' giving column header and data values + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { set range "" @@ -2499,7 +2588,9 @@ tcl::namespace::eval textblock { set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] set hval_lines [split $hdr \n] - set hval_lines [concat $hval_lines $hcell_lines] + #jmn concat + #set hval_lines [concat $hval_lines $hcell_lines] + set hval_lines [list {*}$hval_lines {*}$hcell_lines] set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top set hval_block [::join $hval_lines \n] set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] @@ -2556,12 +2647,14 @@ tcl::namespace::eval textblock { set cval_lines [split $cval \n] - set cval_lines [concat $cval_lines $cell_lines] + #jmn + #set cval_lines [concat $cval_lines $cell_lines] + lappend cval_lines {*}$cell_lines set cval_lines [lrange $cval_lines 0 $rowh-1] set cval_block [::join $cval_lines \n] - - set cell [textblock::pad $cval_block -width $datawidth -padchar " " -within_ansi 1 -which $pad] + #//JMN assert widest cval_line = datawidth = known_blockwidth + set cell [textblock::pad $cval_block -known_blockwidth $datawidth -width $datawidth -padchar " " -within_ansi 1 -which $pad] #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] tcl::dict::lappend output cells $cell @@ -2570,6 +2663,10 @@ tcl::namespace::eval textblock { return $output } method get_column_values_by_index {index_expression} { + #*** !doctools + #[call class::table [method get_column_values_by_index] [arg index_expression]] + #[para] List the cell values of a column from the data area only (no header values) + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { return @@ -2577,6 +2674,10 @@ tcl::namespace::eval textblock { return [tcl::dict::get $o_columndata $cidx] } method debug {args} { + #*** !doctools + #[call class::table [method debug]] + #[para] display lots of debug information about how the table is constructed. + #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) set defaults [tcl::dict::create\ -usetables 1\ @@ -2759,12 +2860,20 @@ tcl::namespace::eval textblock { } method column_width {index_expression} { + #*** !doctools + #[call class::table [method column_width] [arg index_expression]] + #[para] inner width of column ie the available cell-width without borders/separators + if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { my calculate_column_widths -algorithm $o_column_width_algorithm } return [lindex $o_calculated_column_widths $index_expression] } method column_widths {} { + #*** !doctools + #[call class::table [method column_width]] + #[para] ordered list of column widths (inner widths) + if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { my calculate_column_widths -algorithm $o_column_width_algorithm } @@ -2774,7 +2883,12 @@ tcl::namespace::eval textblock { #width of a table includes borders and seps #whereas width of a column refers to the borderless width (inner width) method width {} { - #calculate width based on assumption frame verticals are 1-wide - review - what about custom unicode double-wide frame? + #*** !doctools + #[call class::table [method width]] + #[para] width of the table including borders and separators + #[para] calculate width based on assumption frame verticals are 1 screen-column wide + #[para] (review - consider possibility of custom unicode double-wide frame?) + set colwidths [my column_widths] set contentwidth [tcl::mathop::+ {*}$colwidths] set twidth $contentwidth @@ -3284,6 +3398,11 @@ tcl::namespace::eval textblock { #spangroups keyed by column method spangroups {} { + #*** !doctools + #[call class::table [method spangroups]] + #[para] return a dict keyed by column-index showing advanced span information + #[para] (debug tool) + set column_count [tcl::dict::size $o_columndefs] set spangroups [tcl::dict::create] set headerwidths [tcl::dict::create] ;#key on col,hrow @@ -3655,6 +3774,10 @@ tcl::namespace::eval textblock { #print headers and body using different join mechanisms # using -startcolumn to do slightly less work method print {args} { + #*** !doctools + #[call class::table [method print]] + #[para] Return the table as text suitable for console display + if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] } else { @@ -3775,6 +3898,14 @@ tcl::namespace::eval textblock { } } method print_bodymatrix {} { + #*** !doctools + #[call class::table [method print_bodymatrix]] + #[para] output the matrix string corresponding to the body data using the matrix 2string format + #[para] this will be a table without borders,headers,title etc and will exclude additional ANSI applied due to table, row or column settings. + #[para] If the original cell data itself contains ANSI - the output will still contain those ansi codes. + # + + set m [my as_matrix] $m format 2string } @@ -3793,6 +3924,14 @@ tcl::namespace::eval textblock { #Note: A textblock does not necessarily have lines the same length - either in number of characters or print-width # tcl::namespace::eval textblock { + variable frametypes + set frametypes [list light light_b light_c heavy heavy_b heavy_c arc arc_b arc_c double block block1 block2 block2hack ascii altg] + #class::table needs to be able to determine valid frametypes + proc frametypes {} { + variable frametypes + return $frametypes + } + tcl::namespace::eval cd { #todo - save and restore existing tcl::namespace::export in case macros::cd has default exports in future tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export *} @@ -4020,7 +4159,7 @@ tcl::namespace::eval textblock { if {[dict get $opts -frame]} { #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - set output [textblock::frame -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] } else { set output [$t print] } @@ -4030,50 +4169,52 @@ tcl::namespace::eval textblock { return $t } - proc list_as_table {args} { - set argd [punk::args::get_dict [string map [list $::textblock::frametypes] { - -return -default table -choices {table tableobject} - -frametype -default "" -help "frame type: or dict for custom frame" - -show_edge -default "" -type boolean -help "show outer border of table" - -show_seps -default "" -type boolean - -show_vseps -default "" -type boolean -help "Show vertical table separators" - -show_hseps -default "" -type boolean -help "Show horizontal table separators + set FRAMETYPES [textblock::frametypes] + punk::args::Get_argspecs [punk::lib::tstr -return string { + *id textblock::list_as_table + + -return -default table -choices {table tableobject} + -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ + -help "frame type or dict for custom frame" + -show_edge -default "" -type boolean\ + -help "show outer border of table" + -show_seps -default "" -type boolean + -show_vseps -default "" -type boolean\ + -help "Show vertical table separators" + -show_hseps -default "" -type boolean\ + -help "Show horizontal table separators (default 0 if no existing -table supplied)" - -table -default "" -type string -help "existing table object to use" - -colheaders -default "" -type list -help "list of lists. list of column header values. Outer list must match number of columns" - -header -default "" -type list -multiple 1 -help "Headers left to right" - -show_header -default "" -help "Whether to show a header row. - Leave as empty string for unspecified/automatic, - in which case it will display only if -headers list was supplied." - -action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied + -table -default "" -type string\ + -help "existing table object to use" + -colheaders -default "" -type list\ + -help "list of lists. list of column header values. Outer list must match number of columns" + -header -default "" -type list -multiple 1\ + -help "Each supplied -header argument is a header row. + The number of values for each must be <= number of columns" + -show_header -default ""\ + -help "Whether to show a header row. + Leave as empty string for unspecified/automatic, + in which case it will display only if -headers list was supplied." + -action -default "append" -choices {append replace}\ + -help "row insertion method if existing -table is supplied if append is chosen the new values will always start at the first column" - -columns -default "" -type integer -help "Number of table columns + -columns -default "" -type integer\ + -help "Number of table columns Will default to 2 if not using an existing -table object" - *values -min 0 -max 1 - datalist -default {} -help "flat list of table cell values which will be wrapped based on -columns value" - }] $args] + + *values -min 0 -max 1 + datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value" + }] + + proc list_as_table {args} { + set FRAMETYPES [textblock::frametypes] + set argd [punk::args::get_dict_by_id textblock::list_as_table $args] + set opts [dict get $argd opts] set datalist [dict get $argd values datalist] set existing_table [dict get $opts -table] set opt_columns [dict get $opts -columns] - #set opts [tcl::dict::create\ - # -return string\ - # -frametype \uFFEF\ - # -show_edge \uFFEF\ - # -show_seps \uFFEF\ - #] - #foreach {k v} $args { - # switch -- $k { - # -return - -show_edge - -show_seps - -frametype { - # tcl::dict::set opts $k $v - # } - # default { - # error "unrecognised option '$k'. Known options [tcl::dict::keys $opts]" - # } - # } - #} - set count [llength $datalist] set is_new_table 0 @@ -4167,15 +4308,12 @@ tcl::namespace::eval textblock { } } #defaults for new table only - if {[tcl::dict::get $opts -frametype] eq ""} { - tcl::dict::set opts -frametype "light" - } + #if {[tcl::dict::get $opts -show_seps] eq ""} { + # tcl::dict::set opts -show_seps 1 + #} if {[tcl::dict::get $opts -show_edge] eq ""} { tcl::dict::set opts -show_edge 1 } - if {[tcl::dict::get $opts -show_seps] eq ""} { - tcl::dict::set opts -show_seps 1 - } if {[tcl::dict::get $opts -show_vseps] eq ""} { tcl::dict::set opts -show_vseps 1 } @@ -4224,7 +4362,8 @@ tcl::namespace::eval textblock { foreach row $rowdata { set shortfall [expr {$cols - [llength $row]}] if {$shortfall > 0} { - set row [concat $row [lrepeat $shortfall ""]] + #set row [concat $row [lrepeat $shortfall ""]] + lappend row {*}[lrepeat $shortfall ""] } $t add_row $row } @@ -4307,7 +4446,7 @@ tcl::namespace::eval textblock { - set chars [concat [punk::lib::range 1 9] A B C D E F] + set chars [list {*}[punk::lib::range 1 9] A B C D E F] set charsubset [lrange $chars 0 $size-1] if {"noreset" in $colour} { set RST "" @@ -4386,6 +4525,37 @@ tcl::namespace::eval textblock { } return [punk::char::ansifreestring_width $textblock] } + #gather info about whether ragged (samewidth each line = false) and min width + proc widthinfo {textblock} { + #backspaces, vertical tabs ? + if {$textblock eq ""} { + return [dict create width 0 minwidth 0 ragged 0] + } + #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review + if {[tcl::string::last \t $textblock] >= 0} { + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set textblock [textutil::tabify::untabify2 $textblock $tw] + } + if {[punk::ansi::ta::detect $textblock]} { + #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + #return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + set widths [lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}] + set max [tcl::mathfunc::max {*}$widths] + set min [tcl::mathfunc::min {*}$widths] + set ragged [expr {$min != $max}] + return [dict create width $max minwidth $min ragged $ragged] + } + #single line + set w [punk::char::ansifreestring_width $textblock] + return [dict create width $w minwidth $w ragged 0] + } #when we know the block is uniform in width - just examine topline proc widthtopline {textblock} { set firstnl [tcl::string::first \n $textblock] @@ -4489,17 +4659,22 @@ tcl::namespace::eval textblock { set opts [tcl::dict::create\ -padchar " "\ -which "right"\ + -known_blockwidth ""\ + -known_samewidth ""\ + -known_hasansi ""\ -width ""\ -overflow 0\ -within_ansi 0\ ] + #known_samewidth of empty string means we don't know either way, 0 is definitely 'ragged', 1 is definitely homogenous + #review!? #-within_ansi means after a leading ansi code when doing left pad on all but last line #-within_ansi means before a trailing ansi code when doing right pad on all but last line - set usage "pad ?-padchar |? ?-which right|left|centre? ?-width auto|? ?-within_ansi 1|0?" + set usage "pad ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" foreach {k v} $args { switch -- $k { - -padchar - -which - -width - -overflow - -within_ansi { + -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { tcl::dict::set opts $k $v } default { @@ -4551,11 +4726,38 @@ tcl::namespace::eval textblock { } } # -- --- --- --- --- --- --- --- --- --- - - set datawidth [textblock::width $block] + set known_blockwidth [tcl::dict::get $opts -known_blockwidth] + set known_samewidth [tcl::dict::get $opts -known_samewidth] ;# if true - we have a known non-ragged block, if false - could be either. + set datawidth "" if {$width eq "auto"} { - set width $datawidth + #for auto - we + if {$known_blockwidth eq ""} { + if {$known_samewidth ne "" && $known_samewidth} { + set datawidth [textblock::widthtopline $block] + } else { + #set datawidth [textblock::width $block] + set widthinfo [textblock::widthinfo $block] + set known_samewidth [expr {![dict get $widthinfo ragged]}] ;#review - a false value here is definite, distinguished from unknown which would be empty string - so we can take advantage of it + set datawidth [dict get $widthinfo width] + } + } else { + set datawidth $known_blockwidth + } + set width $datawidth ;# this is the width we want to pad out to + #assert datawidth has been set to widest line, taking ansi & 2wide chars into account + } else { + #only call width functions if known_samewidth - otherwise let the pad algorithm below determine it as we go + if {$known_samewidth ne "" && $known_samewidth} { + if {$known_blockwidth eq ""} { + set datawidth [textblock::widthtopline $block + } else { + set datawidth $known_blockwidth + } + } + #assert datawidth may still be empty string } + #assertion + #we can now use the states of datawidth and known_samewidth to determine if algorithm below should calculate widths as it goes. set lines [list] @@ -4578,39 +4780,45 @@ tcl::namespace::eval textblock { #review - tcl format can only pad with zeros or spaces? #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - if 0 { - #review - surprisingly, this doesn't seem to be a performance win - #No detectable diff on small blocks - slightly worse on large blocks - if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { - #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position - #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. - set block [tcl::string::map [list \r\n \n] $block] - if {$which eq "l"} { - set fmt "%+${padchar}*s" - } else { - set fmt "%-${padchar}*s" - } - foreach ln [split $block \n] { - #set lnwidth [punk::char::ansifreestring_width $ln] - set lnwidth [punk::char::grapheme_width_cached $ln] - set lnlen [tcl::string::length $ln] - set diff [expr $lnwidth - $lnlen] - #we need trickwidth to get format to pad a string with a different terminal width compared to string length - set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) - lappend lines [format $fmt $trickwidth $ln] - } - return [::join $lines \n] - } - } + #review - surprisingly, this doesn't seem to be a performance win + #No detectable diff on small blocks - slightly worse on large blocks + # if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { + # #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position + # #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. + # set block [tcl::string::map [list \r\n \n] $block] + # if {$which eq "l"} { + # set fmt "%+${padchar}*s" + # } else { + # set fmt "%-${padchar}*s" + # } + # foreach ln [split $block \n] { + # #set lnwidth [punk::char::ansifreestring_width $ln] + # set lnwidth [punk::char::grapheme_width_cached $ln] + # set lnlen [tcl::string::length $ln] + # set diff [expr $lnwidth - $lnlen] + # #we need trickwidth to get format to pad a string with a different terminal width compared to string length + # set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) + # lappend lines [format $fmt $trickwidth $ln] + # } + # return [::join $lines \n] + # } #todo? special case trailing double-reset - insert between resets? set lnum 0 - if {[punk::ansi::ta::detect $block]} { + + set known_hasansi [tcl::dict::get $opts -known_hasansi] + if {$known_hasansi eq ""} { + set block_has_ansi [punk::ansi::ta::detect $block] + } else { + set block_has_ansi $known_hasansi + } + if {$block_has_ansi} { set parts [punk::ansi::ta::split_codes $block] } else { #single plaintext part set parts [list $block] } + set line_chunks [list] set line_len 0 set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad @@ -4628,10 +4836,16 @@ tcl::namespace::eval textblock { foreach pl $partlines { lappend line_chunks $pl #incr line_len [punk::char::ansifreestring_width $pl] - incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + } if {$p != $last} { #do padding - set missing [expr {$width - $line_len}] + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + set missing [expr {$width - $line_len}] + } else { + set missing [expr {$width - $datawidth}] + } if {$missing > 0} { #commonly in a block - many lines will have the same pad - cache based on missing @@ -4702,7 +4916,11 @@ tcl::namespace::eval textblock { } } #pad last line - set missing [expr {$width - $line_len}] + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + set missing [expr {$width - $line_len}] + } else { + set missing [expr {$width - $datawidth}] + } if {$missing > 0} { if {[tcl::dict::exists $pad_cache $missing]} { set pad [tcl::dict::get $pad_cache $missing] @@ -4788,12 +5006,12 @@ tcl::namespace::eval textblock { proc pad_test {block} { set width [textblock::width $block] set padtowidth [expr {$width + 10}] - set left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - set left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - set left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - set right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - set right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - set right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] + set left0 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 0] + set left1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 1] + set left2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 2] + set right0 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 0] + set right1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 1] + set right2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 2] set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] @@ -4997,6 +5215,50 @@ tcl::namespace::eval textblock { # -- is a legimate block #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) + if {![llength $blocks]} { + return + } + set rowcount 0 + set blocklists [list] + foreach b $blocks { + if {[punk::ansi::ta::detect $b]} { + #-ansireplays 1 quite expensive e.g 7ms in 2024 + set bl [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] + } else { + set bl [split $b \n] + } + if {[llength $bl] > $rowcount} { + set rowcount [llength $bl] + } + lappend blocklists $bl + } + set outlines [list] + for {set r 0} {$r < $rowcount} {incr r} { + set row "" + for {set c 0} {$c < [llength $blocks]} {incr c} { + append row [lindex $blocklists $c $r] + } + lappend outlines $row + } + return [::join $outlines \n] + } + proc ::textblock::join_basic2 {args} { + #*proc -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. + # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner + #" + set argd [punk::args::get_dict { + -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" + -ansiresets -type any -default auto + blocks -type any -multiple 1 + } $args] + set ansiresets [tcl::dict::get $argd opts -ansiresets] + set blocks [tcl::dict::get $argd values blocks] + + #-ansireplays is always on (if ansi detected) + + # -- is a legimate block + #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) + if {![llength $blocks]} { return } @@ -5068,6 +5330,188 @@ tcl::namespace::eval textblock { return } + set idx 0 + set blocklists [list] + set rowcount 0 + foreach b $blocks { + #we need the width of a rendered block for per-row renderline calls or padding + #we may as well use widthinfo to also determine raggedness state to pass on to pad function + #set bwidth [width $b] + set widthinfo [widthinfo $b] + set bwidth [dict get $widthinfo width] + set is_samewidth [expr {![dict get $widthinfo ragged]}] + + #set c($idx) [tcl::string::repeat " " [set w($idx)]] + #fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n- + #for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi. + #testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway. + + #blocks passed to join can be ragged - so we can't pass -known_samewidth to pad + if {[punk::ansi::ta::detect $b]} { + # - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?) + set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n] + set bl [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] + } else { + #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi + set bl [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] + } + set rowcount [expr {max($rowcount,[llength $bl])}] + lappend blocklists $bl + set width($idx) $bwidth + incr idx + } + + set outlines [list] + for {set r 0} {$r < $rowcount} {incr r} { + set row "" + for {set c 0} {$c < [llength $blocklists]} {incr c} { + set cell [lindex $blocklists $c $r] + if {$cell eq ""} { + set cell [string repeat " " $width($c)] + } + append row $cell + } + lappend outlines $row + } + return [::join $outlines \n] + } + + proc ::textblock::join2 {args} { + #set argd [punk::args::get_dict { + # blocks -type string -multiple 1 + #} $args] + #set opts [tcl::dict::get $argd opts] + #set blocks [tcl::dict::get $argd values blocks] + + #-ansireplays is always on (if ansi detected) + + #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets + #textblock::join is already somewhat expensive - we don't want to do much argument processing + #also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation + #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) + set ansiresets auto + switch -- [lindex $args 0] { + -- { + set blocks [lrange $args 1 end] + } + -ansiresets { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory." + } + } + default { + if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} { + error "first flag must be -ansiresets or end of opts marker --" + } else { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory" + } + } + } + } + + if {![llength $blocks]} { + return + } + + set idx 0 + set fordata [list] + set colindices [list] + foreach b $blocks { + set w($idx) [width $b] ;#we need the width of a rendered block for per-row renderline calls or padding + #set c($idx) [tcl::string::repeat " " [set w($idx)]] + #fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n- + #for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi. + #testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway. + if {[punk::ansi::ta::detect $b]} { + #lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] + + # - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?) + set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n] + lappend fordata "v($idx)" [split [textblock::pad $replay_block -known_hasansi 1 -known_blockwidth $w($idx) -width $w($idx) -which right -padchar " "] \n] + } else { + #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi + #lappend fordata "v($idx)" [split $b \n] + lappend fordata "v($idx)" [split [textblock::pad $b -known_hasansi 0 -known_blockwidth $w($idx) -width $w($idx) -which right -padchar " "] \n] + } + lappend colindices $idx + incr idx + } + + + + + set outlines [list] + #set colindices [lsort -integer -increasing [array names c]] + foreach {*}$fordata { + set row "" + foreach colidx $colindices { + #we know we have a single line, no ansi in underlay and no overflow required - so we can use renderline directly + #append row [overtype::renderline -width $w($colidx) -insert_mode 0 -info 0 $c($colidx) $v($colidx)] + #append row [textblock::pad $v($colidx) -width $w($colidx) -which right -padchar " "] + + #short blocks need to have empty lines padded too + if {$v($colidx) eq ""} { + append row [string repeat " " $w($colidx)] + } else { + append row $v($colidx) + } + } + lappend outlines $row + } + return [::join $outlines \n] + } + # This calls textblock::pad per cell :/ + proc ::textblock::join3 {args} { + #set argd [punk::args::get_dict { + # blocks -type string -multiple 1 + #} $args] + #set opts [tcl::dict::get $argd opts] + #set blocks [tcl::dict::get $argd values blocks] + + #-ansireplays is always on (if ansi detected) + + #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets + #textblock::join is already somewhat expensive - we don't want to do much argument processing + #also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation + #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) + set ansiresets auto + switch -- [lindex $args 0] { + -- { + set blocks [lrange $args 1 end] + } + -ansiresets { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory." + } + } + default { + if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} { + error "first flag must be -ansiresets or end of opts marker --" + } else { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory" + } + } + } + } + + if {![llength $blocks]} { + return + } + set idx 0 set fordata [list] set colindices [list] @@ -5097,6 +5541,7 @@ tcl::namespace::eval textblock { } lappend outlines $row } + #puts stderr "--->outlines len: [llength $outlines]" return [::join $outlines \n] } @@ -5122,7 +5567,7 @@ tcl::namespace::eval textblock { set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] set testblock [textblock::testblock 15 rainbow] set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] - set framed [textblock::frame -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] + set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] } @@ -5163,13 +5608,13 @@ tcl::namespace::eval textblock { append out $punks \n append out $cpunks \n append out [textblock::join -- $punks $cpunks] \n - set 2frames_a [textblock::join -- [textblock::frame $cpunks] [textblock::frame $punks]] + set 2frames_a [textblock::join -- [textblock::frame -checkargs 0 $cpunks] [textblock::frame -checkargs 0 $punks]] append out $2frames_a \n - set 2frames_b [textblock::join -- [textblock::frame -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -ansiborder $greenb -title "fancypunks" $cpunks]] - append out [textblock::frame -title "punks" $2frames_b\n$RST$2frames_a] \n - set fancy [overtype::right [overtype::left [textblock::frame -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nL\nI\nF\nE"] + set 2frames_b [textblock::join -- [textblock::frame -checkargs 0 -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -checkargs 0 -ansiborder $greenb -title "fancypunks" $cpunks]] + append out [textblock::frame -checkargs 0 -title "punks" $2frames_b\n$RST$2frames_a] \n + set punkdeck [overtype::right [overtype::left [textblock::frame -checkargs 0 -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nD\nE\nC\nK"] set spantable [[spantest] print] - append out [textblock::join -- $fancy " " $spantable] \n + append out [textblock::join -- $punkdeck " " $spantable] \n #append out [textblock::frame -title gr $gr0] append out [textblock::periodic -forcecolour $opt_forcecolour] return $out @@ -5242,17 +5687,10 @@ tcl::namespace::eval textblock { } } - variable frametypes - set frametypes [list light heavy arc double block block1 block2 block2hack ascii altg] - #class::table needs to be able to determine valid frametypes - proc frametypes {} { - variable frametypes - return $frametypes - } proc frametype {f} { #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] switch -- $f { - light - heavy - arc - double - block - block1 - block2 - block2hack - ascii - altg { + light - light_b - light_c - heavy - heavy_b - heavy_c - arc - arc_b - arc_c - double - block - block1 - block2 - block2hack - ascii - altg { return [tcl::dict::create category predefined type $f] } default { @@ -5262,6 +5700,9 @@ tcl::namespace::eval textblock { foreach {k v} $f { switch -- $k { hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + hltj - hlbj - vllj - vlrj { + #also allow extra join arguments + } default { #k not in custom_keys set is_custom_dict_ok 0 @@ -5295,8 +5736,6 @@ tcl::namespace::eval textblock { return [tcl::dict::get $framedef_cache $cache_key] } - set argopts [lrange $args 0 end-1] - set f [lindex $args end] #here we avoid the punk::args usage on the happy path, even though punk::args is fairly fast, in favour of an even faster literal switch on the happy path #this means we have some duplication in where our flags/opts are defined: here in opts, and in spec below to give nicer error output without affecting performance. @@ -5306,29 +5745,101 @@ tcl::namespace::eval textblock { -boxonly 0\ ] set bad_option 0 - foreach {k v} $argopts { - switch -- $k { + set values [list] + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + set a2 [tcl::prefix match -error "" {-- -joins -boxonly} $a] + switch -- $a2 { -joins - -boxonly { - tcl::dict::set opts $k $v + tcl::dict::set opts $a2 [lindex $args [incr i]] + } + -- { + set values [lrange $args $i+1 end] + break } default { - set bad_option + if {[string match -* $a]} { + set bad_option 1 + } else { + set values [lrange $args $i end] + } break } } } - if {[llength $args] % 2 == 0 || $bad_option} { + set f [lindex $values 0] + set rawglobs [lrange $values 1 end] + if {![llength $rawglobs]} { + set globs * + } else { + set globs [list] + foreach g $rawglobs { + switch -- $g { + hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - + hltj - hlbj - vllj - vlrj { + lappend globs $g + } + corner - corners { + lappend globs tlc blc trc brc + } + noncorner - noncorners { + #same as verticals + horizontals + lappend globs hl* vl* + } + vertical - verticals { + #we don't consider the corners part of this + lappend globs vl* + } + horizontal - horizontals { + lappend globs hl* + } + top - tops { + lappend globs tlc trc hlt* + } + bottom - bottoms { + lappend globs blc brc hlb* + } + left - lefts - lhs { + lappend globs tlc blc vll* + } + right - rights - rhs { + lappend globs trc brc vlr* + } + default { + #must look like a glob search if not one of the above + if {[regexp {[*?\[\]]} $g]} { + lappend globs $g + } else { + set bad_option 1 + } + } + } + } + } + if {$bad_option || [llength $values] == 0} { #no framedef supplied, or unrecognised opt seen set spec [string map [list $::textblock::frametypes] { - *proc -name textblock::framedef - -joins -default "" -help "List of join directions, any of: up down left right - or those combined with another frametype e.g left-heavy down-light" - -boxonly -default 0 -help "-boxonly true restricts results to the corner,vertical and horizontal box elements - It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj" - *values -min 1 -max 1 - frametype -choices "" -choiceprefix 0 -help "name from the predefined frametypes - or an adhoc dictionary." - }] + *id textblock::framedef + *proc -name textblock::framedef\ + -help "Return a dict of the elements that make up a frame border. + May return a subset of available elements based on memberglob values." + + -joins -default "" -type list\ + -help "List of join directions, any of: up down left right + or those combined with another frametype e.g left-heavy down-light." + -boxonly -default 0 -type boolean\ + -help "-boxonly true restricts results to the corner,vertical and horizontal box elements + It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." + + *values -min 1 + frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ + -help "name from the predefined frametypes or an adhoc dictionary." + memberglob -type globstring -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { + corner noncorner top bottom vertical horizontal left right + hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj + }\ + -help "restrict to keys matching memberglob." + }] #append spec \n "frametype -help \"A predefined \"" punk::args::get_dict $spec $args return @@ -5562,7 +6073,8 @@ tcl::namespace::eval textblock { #set targetdown,targetleft,targetright,targetup vars #default empty targets to current box type 'light' foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] + set rawtarget [tcl::dict::get $join_targets $dir] + lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same switch -- $target { "" - light { set target$dir light @@ -5778,6 +6290,46 @@ tcl::namespace::eval textblock { } #four way junction (cd::fwj) (punk::ansi::g0 n) (punk::char::charshort lvhz) (+) } + light_b { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] + tcl::dict::with arcframe {} ;#extract keys as vars + } + light_c { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] + tcl::dict::with arcframe {} ;#extract keys as vars + } "heavy" { #unicode box drawing set set hl [punk::char::charshort boxd_hhz] ;# light horizontal @@ -6010,6 +6562,46 @@ tcl::namespace::eval textblock { } } } + heavy_b { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] + tcl::dict::with arcframe {} ;#extract keys as vars + } + heavy_c { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] + tcl::dict::with arcframe {} ;#extract keys as vars + } "double" { #unicode box drawing set set hl [punk::char::charshort boxd_dhz] ;# double horizontal \U2550 @@ -6184,72 +6776,74 @@ tcl::namespace::eval textblock { #8 #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) + #set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set tlc \U2566 ;# (ttj) + #set blc [punk::char::charshort boxd_huhz] ;# (btj) + set blc \u2569 ;# (btj) #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) + set trc [punk::char::charshort boxd_ddhz] ;# (ttj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) } left_up { #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) + set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_dvl] ;# (rtj) + set blc [punk::char::charshort boxd_duhz] ;# (btj) set hltj \u2569 ;# (btj) set vllj \u2563 ;# (rtj) } right_up { #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) + set tlc [punk::char::charshort boxd_dvr] ;# (ltj) + set trc [punk::char::charshort boxd_dvhz] ;# (fwj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) set hltj \u2569 ;# (btj) set vlrj \u2560 ;# (ltj) } down_left_right { #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_dvhz] ;# (fwj) + set brc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_ddhz] ;# (ttj) + set tlc [punk::char::charshort boxd_ddhz] ;# (ttj) set hlbj \u2566 ;# (ttj) set vlrj \u2560 ;# (ltj) } down_left_up { #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) + set blc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_dvl] ;# (rtj) + set brc [punk::char::charshort boxd_dvl] ;# (rtj) set hltj \u2569 ;# (btj) set hlbj \u2566 ;# (ttj) } down_right_up { #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) + set tlc [punk::char::charshort boxd_dvr] ;# (ltj) + set blc [punk::char::charshort boxd_dvr] ;# (ltj) + set trc [punk::char::charshort boxd_dvhz] ;# (fwj) + set brc [punk::char::charshort boxd_dvhz] ;# (fwj) set hltj \u2569 ;# (btj) set hlbj \u2566 ;# (ttj) } left_right_up { #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) + set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_dvhz] ;# (fwj) + set blc [punk::char::charshort boxd_duhz] ;# (btj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) set hltj \u2569 ;# (btj) } down_left_right_up { #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) + set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) + set blc [punk::char::charshort boxd_dvhz] ;# (fwj) + set trc [punk::char::charshort boxd_dvhz] ;# (fwj) + set brc [punk::char::charshort boxd_dvhz] ;# (fwj) set hltj \u2569 ;# (btj) set hlbj \u2566 ;# (ttj) } @@ -6358,6 +6952,46 @@ tcl::namespace::eval textblock { } } } + arc_b { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] + tcl::dict::with arcframe {} ;#extract keys as vars + } + arc_c { + set hl " " + set hlt " " + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] + tcl::dict::with arcframe {} ;#extract keys as vars + } block1 { #box drawing as far as we can go without extra blocks from legacy computing unicode block - which is unfortunately not commonly supported set hlt \u2581 ;# lower one eighth block @@ -6492,8 +7126,6 @@ tcl::namespace::eval textblock { vll $vll vlr $vlr\ blc $blc hlb $hlb brc $brc\ ] - tcl::dict::set framedef_cache $cache_key $result - return $result } else { set result [tcl::dict::create\ tlc $tlc hlt $hlt trc $trc\ @@ -6504,16 +7136,18 @@ tcl::namespace::eval textblock { vllj $vllj\ vlrj $vlrj\ ] - tcl::dict::set framedef_cache $cache_key $result - return $result } + set result [dict filter $result key {*}$globs] + tcl::dict::set framedef_cache $cache_key $result + return $result } + variable frame_cache set frame_cache [tcl::dict::create] proc frame_cache {args} { set argd [punk::args::get_dict { - -action -default "" -choices {clear} -help "Clear the textblock::frame_cache dictionary" + -action -default {} -choices {clear} -help "Clear the textblock::frame_cache dictionary" -pretty -default 1 -help "Use 'pdict textblock::frame_cache */*' for prettier output" *values -min 0 -max 0 } $args] @@ -6590,72 +7224,148 @@ tcl::namespace::eval textblock { -buildcache 1\ -pad 1\ -crm_mode 0\ + -checkargs 1\ ] #-pad 1 is default so that simple 'textblock::frame "[a+ Red]a \nbbb[a]" extends the bg colour on the short ragged lines (and empty lines) # for ansi art - -pad 0 is likely to be preferable - set expect_optval 0 - set argposn 0 - set pmax [expr {[llength $args]-1}] - set has_contents 0 ;#differentiate between empty string and no content supplied - set contents "" - set arglist [list] - foreach a $args { - if {!$expect_optval} { - if {$argposn < $pmax} { - if {[tcl::string::match -* $a]} { - set expect_optval 1 - lappend arglist $a - } else { - error "textblock::frame expects -option pairs" - } - } else { - set has_contents 1 - set contents $a - } + set has_contents 0 + set arglist $args + if {[llength $args] %2 == 0} { + if {[lindex $args end-1] eq "--"} { + set contents [lpop arglist end] + set has_contents 1 + lpop arglist end ;#drop the end-of-opts flag } else { - lappend arglist $a - set expect_optval 0 + set arglist $args + set contents "" } - incr argposn - } - - #set contents [lindex $args end] - #set arglist [lrange $args 0 end-1] - if {[llength $arglist] % 2 != 0} { - error "Usage frame ?-type unicode|altg|ascii|? ?-title ? ?-subtitle ? ?-width ? ?-ansiborder ? ?-boxlimits hl|hlt|hlb|vl|vll|vlr|tlc|blc|brc? ?-joins left|right|up|down? " + } else { + #set arglist [lrange $args 0 end-1] + #set contents [lindex $args end] + set contents [lpop arglist end] + set has_contents 1 } + #todo args -justify left|centre|right (center) - #todo -blockalignbias -textalignbias? #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache + set optnames [tcl::dict::keys $opts] + set opts_ok 1 ;#default assumption foreach {k v} $arglist { - switch -- $k { + set k2 [tcl::prefix::match -error "" $optnames $k] + switch -- $k2 { -etabs - -type - -boxlimits - -boxmap - -joins - -title - -subtitle - -width - -height - -ansiborder - -ansibase - -blockalign - -textalign - -ellipsis - -crm_mode - - -usecache - -buildcache - -pad { - tcl::dict::set opts $k $v + - -usecache - -buildcache - -pad + - -checkargs { + tcl::dict::set opts $k2 $v } default { - error "frame option '$k' not understood. Valid options are [tcl::dict::keys $opts]" + #error "frame option '$k' not understood. Valid options are $optnames" + set opts_ok 0 + break } } } + set check_args [dict get $opts -checkargs] + + #only use punk::args if check_args is true or our basic checks failed + if {!$opts_ok || $check_args} { + #error "Usage frame ?-type unicode|altg|ascii|? ?-title ? ?-subtitle ? ?-width ? ?-ansiborder ? ?-boxlimits hl|hlt|hlb|vl|vll|vlr|tlc|blc|brc? ?-joins left|right|up|down? " + set FRAMETYPES [textblock::frametypes] + set EG [a+ brightblack] + set RST [a] + set argd [punk::args::get_dict [punk::lib::tstr -return string { + *proc -name "textblock::frame"\ + -help "Frame a block of text with a border." + -checkargs -default 1 -type boolean\ + -help "If true do extra argument checks and + provide more comprehensive error info. + Set false for slight performance improvement." + -etabs -default 0\ + -help "expanding tabs - experimental/unimplemented." + -type -default light -choices {${$FRAMETYPES}} -choicerestricted 0 -type dict\ + -help "Type of border for frame." + -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. + passing an empty string will result in no box, but title/subtitle will still appear if supplied. + ${$EG}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${$RST}" + -boxmap -default {} -type dict + -joins -default {} -type list + -title -default "" -type string -regexprefail {\n}\ + -help "Frame title placed on topbar - no newlines. + May contain ANSI - no trailing reset required. + ${$EG}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${$RST}" + -subtitle -default "" -type string -regexprefail {\n}\ + -help "Frame subtitle placed on bottombar - no newlines + May contain Ansi - no trailing reset required." + -width -default "" -type int\ + -help "Width of resulting frame including borders. + If omitted or empty-string, the width will be determined automatically based on content." + -height -default "" -type int\ + -help "Height of resulting frame including borders." + -ansiborder -default "" -type ansistring\ + -help "Ansi escape sequence to set border attributes. + ${$EG}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${$RST}" + -ansibase -default "" -type ansistring\ + -help "Default ANSI attributes within frame." + -blockalign -default centre -choices {left right centre}\ + -help "Alignment of the content block within the frame." + -pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background + extends within the content block inside the frame. + Has no effect if no ANSI in content." + -textalign -default left -choices {left right centre}\ + -help "Alignment of text within the content block. (centre unimplemented)" + -ellipsis -default 1 -type boolean\ + -help "Whether to show elipsis for truncated content and title/subtitle." + -usecache -default 1 -type boolean + -buildcache -default 1 -type boolean + -crm_mode -default 0 -type boolean\ + -help "Show ANSI control characters within frame contents. + (Control Representation Mode) + Frame width doesn't adapt and content may be truncated + so -width may need to be manually set to display more." + + *values -min 0 -max 1 + contents -default "" -type string\ + -help "Frame contents - may be a block of text containing newlines and ANSI. + Text may be 'ragged' - ie unequal line-lengths. + No trailing ANSI reset required. + ${$EG}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${$RST}" + }] $args] + set opts [dict get $argd opts] + set contents [dict get $argd values contents] + } + + # -- --- --- --- --- --- + # cache relevant + set opt_usecache [tcl::dict::get $opts -usecache] + set opt_buildcache [tcl::dict::get $opts -buildcache] + set usecache $opt_usecache ;#may need to override + set opt_etabs [tcl::dict::get $opts -etabs] ;#affects contentwidth - needed before cache determination + set opt_crm_mode [tcl::dict::get $opts -crm_mode] # -- --- --- --- --- --- - set opt_etabs [tcl::dict::get $opts -etabs] set opt_type [tcl::dict::get $opts -type] set opt_boxlimits [tcl::dict::get $opts -boxlimits] set opt_joins [tcl::dict::get $opts -joins] set opt_boxmap [tcl::dict::get $opts -boxmap] - set opt_usecache [tcl::dict::get $opts -usecache] - set opt_buildcache [tcl::dict::get $opts -buildcache] - set opt_pad [tcl::dict::get $opts -pad] - set opt_crm_mode [tcl::dict::get $opts -crm_mode] - set usecache $opt_usecache ;#may need to override set buildcache $opt_buildcache + set opt_pad [tcl::dict::get $opts -pad] + # -- --- --- --- --- --- + set opt_title [tcl::dict::get $opts -title] + set opt_subtitle [tcl::dict::get $opts -subtitle] + set opt_width [tcl::dict::get $opts -width] + set opt_height [tcl::dict::get $opts -height] + # -- --- --- --- --- --- + set opt_ansiborder [tcl::dict::get $opts -ansiborder] + set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_blockalign [tcl::dict::get $opts -blockalign] set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] set known_frametypes $frametypes ;# light, heavey etc as defined in the ::textblock::frametypes variable @@ -6692,6 +7402,7 @@ tcl::namespace::eval textblock { } } } + #review vllj etc? if {!$is_boxlimits_ok} { error "frame option -boxlimits '$opt_boxlimits' must contain only values from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" } @@ -6708,7 +7419,7 @@ tcl::namespace::eval textblock { } } switch -- $target { - "" - light - heavy - ascii - altg - arc - double - custom - block - block1 - block2 {} + "" - light - light_b - light_c - heavy - heavy_b - heavy_c - ascii - altg - arc - arc_b - arc_c - double - custom - block - block1 - block2 {} default { set is_joins_ok 0 break @@ -6719,11 +7430,10 @@ tcl::namespace::eval textblock { error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" } set is_boxmap_ok 1 - #safe jumptable test - #dict for {boxelement subst} $opt_boxmap {} tcl::dict::for {boxelement subst} $opt_boxmap { switch -- $boxelement { hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + hltj - hlbj - vllj - vlrj {} default { set is_boxmap_ok 0 break @@ -6731,7 +7441,7 @@ tcl::namespace::eval textblock { } } if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" } #sorted order down left right up @@ -6756,13 +7466,8 @@ tcl::namespace::eval textblock { set do_joins [::join $join_directions _] - # -- --- --- --- --- --- - set opt_title [tcl::dict::get $opts -title] - set opt_subtitle [tcl::dict::get $opts -subtitle] - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - # -- --- --- --- --- --- - set opt_blockalign [tcl::dict::get $opts -blockalign] + + #JMN switch -- $opt_blockalign { left - right - centre - center {} default { @@ -6778,11 +7483,7 @@ tcl::namespace::eval textblock { error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" } } - # -- --- --- --- --- --- - set opt_ansiborder [tcl::dict::get $opts -ansiborder] - set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental - set opt_ellipsis [tcl::dict::get $opts -ellipsis] # -- --- --- --- --- --- if {$has_contents} { @@ -6793,10 +7494,11 @@ tcl::namespace::eval textblock { set tw 8 } if {$opt_etabs} { + #todo set contents [textutil::tabify::untabify2 $contents $tw] } } - set contents [tcl::string::map [list \r\n \n] $contents] + set contents [tcl::string::map {\r\n \n} $contents] if {$opt_crm_mode} { if {$opt_height eq ""} { set h [textblock::height $contents] @@ -6809,9 +7511,13 @@ tcl::namespace::eval textblock { set w [expr {$opt_width -2}] } set contents [overtype::renderspace -crm_mode 1 -wrap 1 -width $w -height $h "" $contents] + set actual_contentwidth $w + set actual_contentheight $h + } else { + #set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) + #set actual_contentheight [textblock::height $contents] + lassign [textblock::size_as_list $contents] actual_contentwidth actual_contentheight } - set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) - set actual_contentheight [textblock::height $contents] } else { set actual_contentwidth 0 set actual_contentheight 0 @@ -6824,6 +7530,7 @@ tcl::namespace::eval textblock { set titlewith 0 set content_or_title_width $actual_contentwidth } + #opt_subtitle ?? if {$opt_width eq ""} { set frame_inner_width $content_or_title_width @@ -6847,7 +7554,9 @@ tcl::namespace::eval textblock { variable frame_cache #review - custom frame affects frame_inner_width - exclude from caching? #set cache_key [concat $arglist $frame_inner_width $frame_inner_height] - set hashables [concat $arglist $frame_inner_width $frame_inner_height] + #jmn + #set hashables [concat $arglist $frame_inner_width $frame_inner_height] + set hashables [list {*}$arglist $frame_inner_width $frame_inner_height] if {$use_md5} { #package require md5 ;#already required at package load @@ -7207,7 +7916,12 @@ tcl::namespace::eval textblock { } } #set body [textblock::join -- {*}$bodyparts] - set cache_body [textblock::join -- {*}$cache_bodyparts] + + #JMN test + #assert - lhs, cache_inner, rhs non-ragged - so can use join_basic REVIEW + #set cache_body [textblock::join -- {*}$cache_bodyparts] + set cache_body [textblock::join_basic -- {*}$cache_bodyparts] + append fscached $cache_body #append fs $body } @@ -7259,11 +7973,13 @@ tcl::namespace::eval textblock { #review if {[tcl::string::is integer -strict $opt_height] && $actual_contentheight < ($opt_height -2)} { set diff [expr {($opt_height -2) - $actual_contentheight}] - append contents [::join [lrepeat $diff \n] ""] + append contents [::join [lrepeat $diff \n] ""] ;# should not affect actual_contentwidth } + #set cwidth [textblock::width $contents] + set cwidth $actual_contentwidth if {$opt_pad} { - set paddedcontents [textblock::pad $contents -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) + set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) set paddedwidth [textblock::widthtopline $paddedcontents] #review - horizontal truncation if {$paddedwidth > $cache_patternwidth} { @@ -7272,11 +7988,10 @@ tcl::namespace::eval textblock { #important to supply end of opts -- to textblock::join - particularly here with arbitrary data set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays } else { - set cwidth [textblock::width $contents] if {$cwidth > $cache_patternwidth} { set contents [overtype::renderspace -width $cache_patternwidth "" $contents] } - set contentblock [textblock::join -- $contents] + set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line } set tlines [split $template \n]