From 1f68b9aa62ce70aef8826f79958d4dc6c95a5a0c Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Tue, 28 Jan 2025 04:35:59 +1100 Subject: [PATCH] punk::args fixes, auto_execok override --- src/bootsupport/modules/commandstack-0.3.tm | 10 +- src/bootsupport/modules/overtype-1.6.5.tm | 309 +- src/bootsupport/modules/punk-0.1.tm | 242 +- .../modules/punk/aliascore-0.1.0.tm | 1 + src/bootsupport/modules/punk/ansi-0.1.1.tm | 2 + src/bootsupport/modules/punk/args-0.1.0.tm | 1930 ++-- src/bootsupport/modules/punk/char-0.1.0.tm | 4 + src/bootsupport/modules/punk/console-0.1.1.tm | 2 +- .../modules/punk/fileline-0.1.0.tm | 2 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 2 +- .../punk/mix/commandset/module-0.1.0.tm | 2 +- src/bootsupport/modules/punk/nav/fs-0.1.0.tm | 4 +- src/bootsupport/modules/punk/ns-0.1.0.tm | 122 +- src/bootsupport/modules/punk/path-0.1.0.tm | 2 +- src/bootsupport/modules/punk/repo-0.1.1.tm | 39 +- src/bootsupport/modules/textblock-0.1.2.tm | 2 +- src/bootsupport/modules/textblock-0.1.3.tm | 8567 +++++++++++++++++ src/modules/argparsingtest-999999.0a1.0.tm | 4 +- src/modules/patternpunk-1.1.tm | 3 +- src/modules/poshinfo-999999.0a1.0.tm | 2 +- src/modules/punk-0.1.tm | 242 +- src/modules/punk/aliascore-999999.0a1.0.tm | 1 + src/modules/punk/ansi-999999.0a1.0.tm | 2 + src/modules/punk/args-999999.0a1.0.tm | 1930 ++-- src/modules/punk/args/tclcore-999999.0a1.0.tm | 100 +- src/modules/punk/blockletter-999999.0a1.0.tm | 8 +- src/modules/punk/char-999999.0a1.0.tm | 4 + src/modules/punk/console-999999.0a1.0.tm | 2 +- src/modules/punk/fileline-999999.0a1.0.tm | 2 +- .../mix/commandset/loadedlib-999999.0a1.0.tm | 2 +- .../mix/commandset/module-999999.0a1.0.tm | 2 +- src/modules/punk/nav/fs-999999.0a1.0.tm | 4 +- src/modules/punk/ns-999999.0a1.0.tm | 122 +- src/modules/punk/path-999999.0a1.0.tm | 2 +- src/modules/punk/repl-0.1.tm | 2 +- src/modules/punk/repo-999999.0a1.0.tm | 39 +- src/modules/punk/safe-999999.0a1.0.tm | 8 +- src/modules/punk/sixel-999999.0a1.0.tm | 2 +- src/modules/punk/winshell-999999.0a1.0.tm | 376 + src/modules/punk/winshell-buildversion.txt | 3 + src/modules/textblock-999999.0a1.0.tm | 93 +- src/modules/textblock-buildversion.txt | 2 +- .../bootsupport/modules/commandstack-0.3.tm | 10 +- .../src/bootsupport/modules/overtype-1.6.5.tm | 309 +- .../src/bootsupport/modules/punk-0.1.tm | 242 +- .../modules/punk/aliascore-0.1.0.tm | 1 + .../bootsupport/modules/punk/ansi-0.1.1.tm | 2 + .../bootsupport/modules/punk/args-0.1.0.tm | 1930 ++-- .../bootsupport/modules/punk/char-0.1.0.tm | 4 + .../bootsupport/modules/punk/console-0.1.1.tm | 2 +- .../modules/punk/fileline-0.1.0.tm | 2 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 2 +- .../punk/mix/commandset/module-0.1.0.tm | 2 +- .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 4 +- .../src/bootsupport/modules/punk/ns-0.1.0.tm | 122 +- .../bootsupport/modules/punk/path-0.1.0.tm | 2 +- .../bootsupport/modules/punk/repo-0.1.1.tm | 39 +- .../bootsupport/modules/textblock-0.1.2.tm | 2 +- .../bootsupport/modules/textblock-0.1.3.tm | 8567 +++++++++++++++++ .../bootsupport/modules/commandstack-0.3.tm | 10 +- .../src/bootsupport/modules/overtype-1.6.5.tm | 309 +- .../src/bootsupport/modules/punk-0.1.tm | 242 +- .../modules/punk/aliascore-0.1.0.tm | 1 + .../bootsupport/modules/punk/ansi-0.1.1.tm | 2 + .../bootsupport/modules/punk/args-0.1.0.tm | 1930 ++-- .../bootsupport/modules/punk/char-0.1.0.tm | 4 + .../bootsupport/modules/punk/console-0.1.1.tm | 2 +- .../modules/punk/fileline-0.1.0.tm | 2 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 2 +- .../punk/mix/commandset/module-0.1.0.tm | 2 +- .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 4 +- .../src/bootsupport/modules/punk/ns-0.1.0.tm | 122 +- .../bootsupport/modules/punk/path-0.1.0.tm | 2 +- .../bootsupport/modules/punk/repo-0.1.1.tm | 39 +- .../bootsupport/modules/textblock-0.1.2.tm | 2 +- .../bootsupport/modules/textblock-0.1.3.tm | 8567 +++++++++++++++++ src/vendormodules/commandstack-0.3.tm | 10 +- src/vendormodules/overtype-1.6.5.tm | 309 +- .../modules/argparsingtest-0.1.0.tm | 4 +- .../modules/commandstack-0.3.tm | 10 +- .../_vfscommon.vfs/modules/overtype-1.6.5.tm | 309 +- .../_vfscommon.vfs/modules/patternpunk-1.1.tm | 3 +- .../_vfscommon.vfs/modules/poshinfo-0.1.0.tm | 2 +- src/vfs/_vfscommon.vfs/modules/punk-0.1.tm | 242 +- .../modules/punk/aliascore-0.1.0.tm | 1 + .../_vfscommon.vfs/modules/punk/ansi-0.1.1.tm | 2 + .../_vfscommon.vfs/modules/punk/args-0.1.0.tm | 1930 ++-- .../modules/punk/args/tclcore-0.1.0.tm | 100 +- .../modules/punk/blockletter-0.1.0.tm | 8 +- .../_vfscommon.vfs/modules/punk/char-0.1.0.tm | 4 + .../modules/punk/console-0.1.1.tm | 2 +- .../modules/punk/fileline-0.1.0.tm | 2 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 2 +- .../punk/mix/commandset/module-0.1.0.tm | 2 +- .../modules/punk/nav/fs-0.1.0.tm | 4 +- .../_vfscommon.vfs/modules/punk/ns-0.1.0.tm | 122 +- .../_vfscommon.vfs/modules/punk/path-0.1.0.tm | 2 +- .../_vfscommon.vfs/modules/punk/repl-0.1.tm | 2 +- .../_vfscommon.vfs/modules/punk/repo-0.1.1.tm | 39 +- .../_vfscommon.vfs/modules/punk/safe-0.1.0.tm | 8 +- .../modules/punk/sixel-0.1.0.tm | 2 +- .../modules/punk/winshell-0.1.0.tm | 376 + .../_vfscommon.vfs/modules/textblock-0.1.2.tm | 2 +- .../_vfscommon.vfs/modules/textblock-0.1.3.tm | 8567 +++++++++++++++++ 104 files changed, 44760 insertions(+), 3989 deletions(-) create mode 100644 src/bootsupport/modules/textblock-0.1.3.tm create mode 100644 src/modules/punk/winshell-999999.0a1.0.tm create mode 100644 src/modules/punk/winshell-buildversion.txt create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/winshell-0.1.0.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm diff --git a/src/bootsupport/modules/commandstack-0.3.tm b/src/bootsupport/modules/commandstack-0.3.tm index d7d9813e..ee486569 100644 --- a/src/bootsupport/modules/commandstack-0.3.tm +++ b/src/bootsupport/modules/commandstack-0.3.tm @@ -211,6 +211,7 @@ namespace eval commandstack { set new_code [string trim $procbody] if {$current_code eq $new_code} { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [show_stack $command] } else { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." puts stdout "----------" @@ -223,6 +224,7 @@ namespace eval commandstack { } } else { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" + puts stderr set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid set do_rename 1 } @@ -374,13 +376,13 @@ namespace eval commandstack { proc show_stack {{commandname_glob *}} { variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } if {[package provide punk::lib] ne ""} { return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] } else { - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } set result "" set matchedkeys [dict keys $all_stacks $commandname_glob] #don't try to calculate widest on empty list diff --git a/src/bootsupport/modules/overtype-1.6.5.tm b/src/bootsupport/modules/overtype-1.6.5.tm index 0d9cd0bc..fb044b3c 100644 --- a/src/bootsupport/modules/overtype-1.6.5.tm +++ b/src/bootsupport/modules/overtype-1.6.5.tm @@ -449,7 +449,7 @@ tcl::namespace::eval overtype { 4 { set inputchunks [list] foreach ln [split $overblock \n] { - lappend inputchunks [string cat $ln \n] + lappend inputchunks $ln\n } if {[llength $inputchunks]} { lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] @@ -499,9 +499,9 @@ tcl::namespace::eval overtype { #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set overtext $replay_codes_overlay$overtext if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::string::cat [tcl::dict::get $replay_codes_underlay $row] $undertext] + set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l @@ -1365,8 +1365,8 @@ tcl::namespace::eval overtype { set udiff [expr {$renderwidth - $ulen}] set undertext "$undertext[string repeat { } $udiff]" } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] #review - right-to-left langs should elide on left! - extra option required @@ -1518,8 +1518,8 @@ tcl::namespace::eval overtype { set startoffset 0 ;#negative? } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] if {$overflowlength > 0} { @@ -1545,7 +1545,7 @@ tcl::namespace::eval overtype { } } if {$show_ellipsis} { - set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] + set ellipsis $replay_codes$opt_ellipsistext #todo - overflow on left if allign = right?? set rendered [overtype::right $rendered $ellipsis] } @@ -1701,8 +1701,8 @@ tcl::namespace::eval overtype { set startoffset 0 ;#negative? } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] if {$overflowlength > 0} { @@ -1769,6 +1769,9 @@ tcl::namespace::eval overtype { return [join $outputlines \n] } + + variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. @@ -1802,6 +1805,7 @@ tcl::namespace::eval overtype { #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. #puts stderr "renderline '$args'" + variable optimise_ptruns if {[llength $args] < 2} { error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} @@ -1973,58 +1977,107 @@ tcl::namespace::eval overtype { foreach {pt code} $undermap { #pt = plain text #append pt_underchars $pt - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. - #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. - #todo - test decimal value instead, compare performance - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - set width 1 + if {$pt ne ""} { + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex + set re [tcl::string::cat {^[} \\U$hex {]+$}] + set is_ptrun [regexp $re $pt] + } + if {$is_ptrun} { + #switch -- $p1 { + # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + # set width 1 + # } + # default { + # if {$p1 eq "\u0000"} { + # #use null as empty cell representation - review + # #use of this will probably collide with some application at some point + # #consider an option to set the empty cell character + # set width 1 + # } else { + # set width [grapheme_width_cached $p1] ;# when zero??? + # } + # } + #} + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] + lappend undercols {*}[lrepeat $ptlen $p1] + } else { + incr i_u $ptlen ;#2nd col empty str - so same as above + set 2ptlen [expr {$ptlen * 2}] + lappend understacks {*}[lrepeat $2ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]] + lappend undercols {*}$l + unset l } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] - set grapheme $gvis + + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + set width 1 + } + default { + if {$grapheme eq "\u0000"} { + #use null as empty cell representation - review + #use of this will probably collide with some application at some point + #consider an option to set the empty cell character set width 1 + } else { + #zero width still acts as 1 below??? review what should happen + set width [grapheme_width_cached $grapheme] + #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length + #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI + #todo - default to off and add a flag (?) to enable this substitution + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. + set grapheme $gvis + set width 1 + } + } } } } + + #set width [grapheme_width_cached $grapheme] + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + + lappend undercols $grapheme + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + #but what about emoji combinations etc - can they be wider than 2? + #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + lappend undercols "" + } } - } - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" + } } - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2168,23 +2221,31 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left of the right number of columns. + #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpad_overlay [string repeat " " [expr {$opt_colstart -1}]] - append startpad_overlay $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - if {$startpad_overlay ne ""} { - if {[punk::ansi::ta::detect $startpad_overlay]} { - set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] + set startpadding [string repeat " " [expr {$opt_colstart -1}]] + #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + if {$startpadding ne "" || $overdata ne ""} { + if {[punk::ansi::ta::detect $overdata]} { + set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] } else { #single plaintext part - set overmap [list $startpad_overlay] + set overmap [list $startpadding$overdata] } } else { set overmap [list] } - #set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] #### + + #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) + #will that allow some optimisations? + + #todo - detect repeated transparent char in overlay + #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. + # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data + #we should be able to optimize to pass through the underlay?? + #??? set colcursor $opt_colstart #TODO - make a little virtual column object @@ -2206,41 +2267,78 @@ tcl::namespace::eval overtype { #experiment set overlay_grapheme_control_stacks [list] foreach {pt code} $overmap { - - #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - if {!$crm_mode} { - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack + if {$pt ne ""} { + #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] } - } else { - set tsbegin [clock micros] - foreach grapheme_original [punk::char::grapheme_split $pt] { - set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] - #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" - foreach grapheme [punk::char::grapheme_split $pt_crm] { - if {$grapheme eq "\n"} { + append pt_overchars $pt + #will get empty pt between adjacent codes + if {!$crm_mode} { + + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] + set is_ptrun [regexp $re $pt] + + #leading only? we would have to check for graphemes at the trailing boundary? + #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] + #set is_ptrun [regexp -indices $re $pt runrange] + #if {$is_ptrun && 1} { + #} + } + if {$is_ptrun} { + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) + set len [string length $pt] + set g_element [list g $p1] + + #lappend overstacks {*}[lrepeat $len $o_codestack] + #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] + #incr i_o $len + #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] + #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] + + set pi 0 + incr i_o $len + while {$pi < $len} { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + lappend overlay_grapheme_control_list $g_element lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] - } else { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack + incr pi + } + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_list [list g $grapheme] lappend overlay_grapheme_control_stacks $o_codestack } } + } else { + set tsbegin [clock micros] + foreach grapheme_original [punk::char::grapheme_split $pt] { + set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" + foreach grapheme [punk::char::grapheme_split $pt_crm] { + if {$grapheme eq "\n"} { + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] + } else { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } - set elapsed [expr {[clock micros] - $tsbegin}] - puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2324,6 +2422,7 @@ tcl::namespace::eval overtype { set o_codestack [list $temp_cursor_saved] lappend overlay_grapheme_control_list [list other $code] } else { + #review if {[punk::ansi::codetype::is_gx_open $code]} { set o_gxstack [list "gx0_on"] lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets @@ -2837,7 +2936,8 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] } 7CSI - 7OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + set codenorm $leadernorm[tcl::string::range $code 2 end] } 7DCS { #ESC P @@ -2849,7 +2949,8 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] } 7ESC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + set codenorm $leadernorm[tcl::string::range $code 1 end] } 8CSI - 8OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] @@ -2886,7 +2987,12 @@ tcl::namespace::eval overtype { A { #Row move - up set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set num $param + #todo + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} incr cursor_row -$num @@ -2904,9 +3010,12 @@ tcl::namespace::eval overtype { B { #CUD - Cursor Down #Row move - down - set num $param + lassign [split $param {;}] num modifierkey set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #move down + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} incr cursor_row $num @@ -2924,7 +3033,10 @@ tcl::namespace::eval overtype { #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. #cursor forward #right-arrow/move forward - set num $param + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} #todo - retrict to moving 1 position past datalen? restrict to column width? @@ -3028,7 +3140,10 @@ tcl::namespace::eval overtype { #puts stdout "<-back" #cursor back #left-arrow/move-back when ltr mode - set num $param + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} set version 2 @@ -4518,7 +4633,7 @@ tcl::namespace::eval overtype::priv { if {$existing eq "\0"} { lset o $i $c } else { - lset o $i [string cat $existing $c] + lset o $i $existing$c } } #is actually addgrapheme? diff --git a/src/bootsupport/modules/punk-0.1.tm b/src/bootsupport/modules/punk-0.1.tm index 1a9ab766..08359461 100644 --- a/src/bootsupport/modules/punk-0.1.tm +++ b/src/bootsupport/modules/punk-0.1.tm @@ -12,6 +12,242 @@ namespace eval punk { #lazyload twapi ? catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later + + variable can_exec_windowsapp + set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed + variable windowsappdir + set windowsappdir "" + variable cmdexedir + set cmdexedir "" + + proc rehash {{refresh 0}} { + global auto_execs + if {!$refresh} { + unset -nocomplain auto_execs + } else { + set names [array names auto_execs] + unset -nocomplain auto_execs + foreach nm $names { + auto_execok_windows $nm + } + } + return + } + + + proc ::punk::auto_execok_original name [info body ::auto_execok] + variable better_autoexec + + #set better_autoexec 0 ;#use this var via better_autoexec only + #proc ::punk::auto_execok_windows name { + # ::punk::auto_execok_original $name + #} + + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + + set has_commandstack [expr {![catch {package require commandstack}]}] + if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} { + + #still a caching version of auto_execok - but with proper(fixed) search order + + #set b [info body ::auto_execok] + #proc ::auto_execok_original name $b + + proc better_autoexec {{onoff ""}} { + variable better_autoexec + if {$onoff eq ""} { + return $better_autoexec + } + if {![string is boolean -strict $onoff]} { + error "better_autoexec argument 'onoff' must be a boolean, received: $onoff" + } + if {$onoff && ($onoff != $better_autoexec)} { + puts "Turning on better_autoexec - search PATH first then extension" + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + punk::rehash + } elseif {!$onoff && ($onoff != $better_autoexec)} { + puts "Turning off better_autoexec - search extension then PATH" + set better_autoexec 0 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_original $name + } + punk::rehash + } else { + puts "no change" + } + } + #better_autoexec $better_autoexec ;#init to default + + + proc auto_execok_better name { + global auto_execs env tcl_platform + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + #puts stdout "[a+ red]...[a]" + set auto_execs($name) "" + + set shellBuiltins [list assoc cls copy date del dir echo erase exit ftype \ + md mkdir mklink move rd ren rename rmdir start time type ver vol] + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + if {[string tolower $name] in $shellBuiltins} { + # When this is command.com for some reason on Win2K, Tcl won't + # exec it unless the case is right, which this corrects. COMSPEC + # may not point to a real file, so do the check. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext $execExtensions { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + return "" + } + + #change1 + #set path "[file dirname [info nameofexecutable]];.;" + set path "[file dirname [info nameofexecutable]];" + + if {[info exists env(SystemRoot)]} { + set windir $env(SystemRoot) + } elseif {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + append path "$windir/system32;$windir/system;$windir;" + } + + foreach var {PATH Path path} { + if {[info exists env($var)]} { + append path ";$env($var)" + } + } + + #change2 + set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + foreach dir [split $path {;}] { + #set dir [file normalize $dir] + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} + + foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] { + set file [file join $dir $match] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + } + + #foreach ext $execExtensions { + #unset -nocomplain checked + #foreach dir [split $path {;}] { + # # Skip already checked directories + # if {[info exists checked($dir)] || ($dir eq "")} { + # continue + # } + # set checked($dir) {} + # set file [file join $dir ${name}${ext}] + # if {[file exists $file] && ![file isdirectory $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + #} + return "" + } + + + + #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? + #what if we create another interp and use the same ::auto_execs? The appdir won't be detected. + #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed + + + + #winget is installed on all modern windows and is an example of the problem this addresses + #we target apps with same location + + #the main purpose of this override is to support windows app executables (installed as 'reparse points') + #for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac + #versions prior to this will use cmd.exe to resolve the links + set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name { + #set windowsappdir "%appdir%" + upvar ::punk::can_exec_windowsapp can_exec_windowsapp + upvar ::punk::windowsappdir windowsappdir + upvar ::punk::cmdexedir cmdexedir + + if {$windowsappdir eq ""} { + #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' + #Tcl (2025) can't exec when given a path to these 0KB files + #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps + if {!([info exists ::env(LOCALAPPDATA)] && + [file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} { + #should be unlikely to get here - unless LOCALAPPDATA missing + set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]] + puts stderr "(resolved winget by search)" + } else { + set windowsappdir [file dirname $testapp] + } + } + + #set default_auto [$COMMANDSTACKNEXT $name] + set default_auto [::punk::auto_execok_windows $name] + #if {$name ni {cmd cmd.exe}} { + # unset -nocomplain ::auto_execs + #} + + if {$default_auto eq ""} { + return + } + set namedir [file dirname [lindex $default_auto 0]] + + if {$namedir eq $windowsappdir} { + if {$can_exec_windowsapp eq "unknown"} { + if {[catch {exec [file join $windowsappdir winget.exe] --version}]} { + set can_exec_windowsapp 0 + } else { + set can_exec_windowsapp 1 + } + } + if {$can_exec_windowsapp} { + return [file join $windowsappdir $name] + } + if {$cmdexedir eq ""} { + #cmd.exe very unlikely to move + set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] + #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index + #anyway.. it has other side effects (affects auto_load) + } + return "[file join $cmdexedir cmd.exe] /c $name" + } + return $default_auto + }] + + + } + } @@ -5321,8 +5557,8 @@ namespace eval punk { } return -options $opts $msg } else { - dict incr opts -level - return -options $opts $msg + dict incr opts -level + return -options $opts $msg } } } @@ -7152,7 +7388,7 @@ namespace eval punk { dict filter $result value {?*} } - punk::args::definition { + punk::args::define { @id -id ::punk::inspect @cmd -name punk::inspect -help\ "Function to display values - used pimarily in a punk pipeline. diff --git a/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/bootsupport/modules/punk/aliascore-0.1.0.tm index c17bacf2..296bb6df 100644 --- a/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -115,6 +115,7 @@ tcl::namespace::eval punk::aliascore { pdict ::punk::lib::pdict\ plist {::punk::lib::pdict -roottype list}\ showlist {::punk::lib::showdict -roottype list}\ + rehash ::punk::rehash\ showdict ::punk::lib::showdict\ ansistrip ::punk::ansi::ansistrip\ stripansi ::punk::ansi::ansistrip\ diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index a3f9c0b5..422c524e 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -5568,6 +5568,7 @@ tcl::namespace::eval punk::ansi::class { } #does not affect object state + #REVIEW - icu or equiv required method DoCount {plaintext} { #- combiners/diacritics just map them away here - but for consistency we need to combine unicode grapheme clusters too. #todo - joiners 200d? zwnbsp @@ -5672,6 +5673,7 @@ tcl::namespace::eval punk::ansi::class { method renderbuf {} { #get the underlying renderobj - if any #return $o_renderout ;#also class_ansistring + if {$o_renderer eq ""} {error "renderbuf error: no active renderer"} return [$o_renderer renderbuf] } method render {{maxgraphemes ""}} { diff --git a/src/bootsupport/modules/punk/args-0.1.0.tm b/src/bootsupport/modules/punk/args-0.1.0.tm index 2c9c77fa..78a18304 100644 --- a/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/bootsupport/modules/punk/args-0.1.0.tm @@ -247,12 +247,12 @@ tcl::namespace::eval punk::args::register { tcl::namespace::eval punk::args { - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::definition at the end. + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. tcl::namespace::export {[a-z]*} variable argdata_cache variable argdefcache_by_id - variable argdefcache_unresolved + variable argdefcache_unresolved ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) variable id_counter set argdata_cache [tcl::dict::create] set argdefcache_by_id [tcl::dict::create] @@ -282,10 +282,18 @@ tcl::namespace::eval punk::args { set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::definition + @id -id ::punk::args::define #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::definition -help\ + @cmd -name punk::args::define -help\ "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + This can be used purely for documentation or called within a function to parse a mix of leading values, switches/flags and trailing values. @@ -427,10 +435,13 @@ tcl::namespace::eval punk::args { " @values -min 1 -max -1 text -type string -multiple 1 -help\ - "Block(s) of text representing the argument specification for a command. + "Block(s) of text representing the argument definition for a command. At least one must be supplied. If multiple, they are joined together with \\n. Using multiple text arguments may be useful to mix curly-braced and double-quoted strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + e.g the following definition passes 2 blocks as text arguments definition { @id -id ::myns::myfunc @@ -450,22 +461,135 @@ tcl::namespace::eval punk::args { } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" " }]] - proc definition {args} { + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -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_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + proc define {args} { variable argdata_cache variable argdefcache_by_id variable argdefcache_unresolved - #variable initial_optspec_defaults - #variable initial_valspec_defaults + set cache_key $args #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) #review - check if there is a built-into-tcl way to do this quickly #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. - set cache_key $args set textargs $args - + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } set is_dynamic 0 if {[lindex $args 0] eq "-dynamic"} { set is_dynamic [lindex $args 1] @@ -485,6 +609,8 @@ tcl::namespace::eval punk::args { set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] } } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] lassign $pt_params ptlist paramlist @@ -509,6 +635,7 @@ tcl::namespace::eval punk::args { tcl::dict::set argdefcache_unresolved $cache_key $pt_params } } + #argdata_cache should be limited in some fashion or will be a big memory leak??? if {[tcl::dict::exists $argdata_cache $optionspecs]} { #resolved cache version exists return [tcl::dict::get $argdata_cache $optionspecs] @@ -517,46 +644,6 @@ tcl::namespace::eval punk::args { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -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_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] #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 @@ -566,21 +653,14 @@ tcl::namespace::eval punk::args { #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 leader_required [list] set opt_required [list] set val_required [list] - set arg_info [tcl::dict::create] - set arg_checks [tcl::dict::create] set opt_defaults [tcl::dict::create] - set opt_names [list] ;#defined opts - set leader_defaults [tcl::dict::create] set val_defaults [tcl::dict::create] set opt_solos [list] - #first process dashed and non-dashed argspecs without regard to whether non-dashed are at the beginning or end - set leader_names [list] - set val_names [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end set records [list] set linebuild "" @@ -602,7 +682,7 @@ tcl::namespace::eval punk::args { foreach rawline $linelist { set recordsofar [tcl::string::cat $linebuild $rawline] #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in argspecs. + #review - when exactly are ansi codes allowed/expected in record lines. # - we might reasonably expect them in default values or choices or help strings # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. # - eg set line "set x \"a[a+ red]red[a]\"" @@ -656,48 +736,137 @@ tcl::namespace::eval punk::args { set id_info {} ;#e.g -children ?? set doc_info {} set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set parser_info {} - set leader_min "" - #set leader_min 0 - #set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - set leader_max "" + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" #(common case of no leaders specified) set opt_any 0 set val_min 0 set val_max -1 ;#-1 for no limit - set spec_id "" - set argspace "leaders" ;#leaders -> options -> values - set parser_id 0 - foreach ln $records { - set trimln [tcl::string::trim $ln] - switch -- [tcl::string::index $trimln 0] { + set DEF_definition_id "" + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { "" - # {continue} } - set linespecs [lassign $trimln argname] - if {[llength $linespecs] % 2 != 0} { - error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs' id:$spec_id" + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } } - set firstchar [tcl::string::index $argname 0] - set secondchar [tcl::string::index $argname 1] + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] if {$firstchar eq "@" && $secondchar ne "@"} { - set at_specs $linespecs + set record_type "directive" + set directive_name $firstword + set at_specs $record_values - switch -- [tcl::string::range $argname 1 end] { + switch -- [tcl::string::range $directive_name 1 end] { id { #id An id will be allocated if no id line present or the -id value is "auto" - if {$spec_id ne ""} { + if {$DEF_definition_id ne ""} { #disallow duplicate @id line - error "punk::args::definition - @id already set. Existing value $spec_id" + error "punk::args::define - @id already set. Existing value $DEF_definition_id" } if {[dict exists $at_specs -id]} { - set spec_id [dict get $at_specs -id] + set DEF_definition_id [dict get $at_specs -id] } else { - set spec_id auto + set DEF_definition_id auto } set id_info $at_specs } + ref { + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } default { - #copy from an identified set of defaults (another argspec id) can be multiple + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define -dynamic 1 making *immediate* resolutions .. is that really desirable? + if {[dict exists $at_specs -id]} { set copyfrom [get_def [dict get $at_specs -id]] #we don't copy the @id info from the source @@ -711,20 +880,27 @@ tcl::namespace::eval punk::args { if {![dict size $doc_info]} { set doc_info [dict get $copyfrom doc_info] } - if {![dict size $argdisplay_info]} { - set argdisplay_info [dict get $copyfrom argdisplay_info] + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? } - #TODO - #create leaders opts vals depending on position of @default line? - #options on @default line to exclude/include sets??? } } } - parser { + form { + # arity system ? #handle multiple parsing styles based on arities and keyword positions (and/or flags?) #e.g see lseq manual with 3 different parsing styles. #aim to produce a table/subtable for each - # *parser -description "start ?('..'|'to')? end ??'by'? step?"\ + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ # -arities { # 2 # {3 anykeys {1 .. 1 to}} @@ -733,24 +909,36 @@ tcl::namespace::eval punk::args { # }\ # -fallback 1 # ... - # *parser -description "start 'count' count ??'by'? step?"\ + # @parser -synopsis "start 'count' count ??'by'? step?"\ # -arities { # {3 anykeys {1 count}} # } # ... - # *parser -description "count ?'by' step?"\ + # @form -synopsis "count ?'by' step?"\ # -arities { # 1 # {3 anykeys {1 by}} # } # # see also after manual - # *parser -arities {1} - # *parser -arities { + # @form -arities {1} + # @form -arities { # 1 anykeys {0 info} # } #todo - set parser_info $at_specs + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) } cmd { #allow arbitrary - review @@ -765,475 +953,644 @@ tcl::namespace::eval punk::args { set argdisplay_info [dict merge $argdisplay_info $at_specs] } opts { - if {$argspace eq "values"} { - error "punk::args::definition - @opts declaration must come before @values - received '$linespecs' id:$spec_id" - } - set argspace "options" - foreach {k v} $at_specs { - switch -- $k { - -any - - -anyopts { - set opt_any $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset optspec_defaults $k2 + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 } - none - "" - - - any - ansistring - globstring - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" } - tcl::dict::set optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set optspec_defaults $k $v - } - default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @opts line. Known keys: $known id:$spec_id" } } - } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids } leaders { - if {$argspace in [list options values]} { - error "punk::args::definition - @leaders declaration must come before all options and values id:$spec_id" - } - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$spec_id" + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} } - set leader_min $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$spec_id" + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v } - set leader_max $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset leaderspec_defaults $k2 + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" } - tcl::dict::set leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set leaderspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @leaders line. Known keys: $known @id:$spec_id" } } - } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids } values { - set argspace "values" - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$spec_id" - } - set val_min $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$spec_id" - } - set val_max $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegoups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset valspec_defaults $k2 + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" } - bool - boolean { - set v bool + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" } - dict - dictionary { - set v dict + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegoups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 } - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" } - tcl::dict::set valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @values line. Known keys: $known @id:$spec_id" } } + dict set F $fid valspec_defaults $tmp_valspec_defaults } } default { - error "punk::args::definition - unrecognised @ line in '$ln'. Expected @id @cmd @leaders @opts or @values - use @@name if paramname needs to be @name @id:$spec_id" + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" } } + #record_type directive continue } elseif {$firstchar eq "-"} { - if {$argspace eq "leaders"} { - set argspace "options" - } elseif {$argspace eq "values"} { - error "punk::args::definition - invalid placement of line '$ln' - must come before @values @id:$spec_id" - } - set argspecs $linespecs - tcl::dict::set argspecs -ARGTYPE option - lappend opt_names $argname + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + set is_opt 1 } else { + set argname $firstword if {$firstchar eq "@"} { #allow basic @@ escaping for literal argname that begins with @ set argname [tcl::string::range $argname 1 end] } - set argspecs $linespecs - if {$argspace eq "leaders"} { - tcl::dict::set argspecs -ARGTYPE leader - lappend leader_names $argname - if {$leader_max >= 0} { - set leader_max [llength $leader_names] + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname } - } else { - tcl::dict::set argspecs -ARGTYPE value - lappend val_names $argname } + set is_opt 0 } + + #assert - we only get here if it is a value or flag specification line. - #assert argspecs has been set to the value of linespecs - if {$is_opt} { - set spec_merged $optspec_defaults - } else { - if {$argspace eq "values"} { - set spec_merged $valspec_defaults + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] } else { - set spec_merged $leaderspec_defaults + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } } - } - foreach {spec specval} $argspecs { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { - tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" } - lappend opt_solos $argname - } else { - #-solo only valid for flags - error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname' @id:$spec_id" } - } - 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] + 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 - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$spec_id" + -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$spec_id" + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" } } - } - default { - set known_argspecs [list -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - ] - error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs @id:$spec_id" - } - } - } - set argspecs $spec_merged - if {$is_opt} { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } else { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set arg_info $argname $argspecs - tcl::dict::set arg_checks $argname $argchecks - #review existence of -default overriding -optional - if {![tcl::dict::get $argspecs -optional] && ![tcl::dict::exists $argspecs -default]} { + } ;# end foreach {spec specval} argdef_values + + if {$is_opt} { - lappend opt_required $argname + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } else { - if {$argspace eq "leaders"} { - lappend leader_required $argname + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname } else { - lappend val_required $argname + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } } } - } - if {[tcl::dict::exists $argspecs -default]} { - if {$is_opt} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $argspecs -default] - } else { - if {$argspace eq "leaders"} { - tcl::dict::set leader_defaults $argname [tcl::dict::get $argspecs -default] + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $argspecs -default] + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } } } - } - } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + - if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { + if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { variable id_counter - set spec_id "autoid_[incr id_counter]" - } - - # REVIEW - #if {[llength $val_names] || $val_min > 0} { - # #some values are specified - # foreach leadername [lrange $leader_names 0 end] { - # if {[tcl::dict::get $arg_info $leadername -multiple]} { - # error "bad key -multiple on argument spec for leader '$leadername'. Last leader argument specification can be marked -multiple only when no values are specified" - # } - # } - #} else { + set DEF_definition_id "autoid_[incr id_counter]" + } + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW #no values specified - we can allow last leader to be multiple - foreach leadername [lrange $leader_names 0 end-1] { - if {[tcl::dict::get $arg_info $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple @id:$spec_id" + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" } } - #} - #confirm any valnames before last don't have -multiple key - foreach valname [lrange $val_names 0 end-1] { - if {[tcl::dict::get $arg_info $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple @id:$spec_id" + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - set leader_checks_defaults [tcl::dict::remove $leaderspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } set argdata_dict [tcl::dict::create\ - id $spec_id\ - arg_info $arg_info\ - arg_checks $arg_checks\ - leader_defaults $leader_defaults\ - leader_required $leader_required\ - leader_names $leader_names\ - leader_min $leader_min\ - leader_max $leader_max\ - leaderspec_defaults $leaderspec_defaults\ - leader_checks_defaults $leader_checks_defaults\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - opt_names $opt_names\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults $optspec_defaults\ - opt_checks_defaults $opt_checks_defaults\ - val_defaults $val_defaults\ - val_required $val_required\ - val_names $val_names\ - val_min $val_min\ - val_max $val_max\ - valspec_defaults $valspec_defaults\ - val_checks_defaults $val_checks_defaults\ - cmd_info $cmd_info\ - doc_info $doc_info\ - argdisplay_info $argdisplay_info\ - id_info $id_info\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + argdisplay_info $argdisplay_info\ + id_info $id_info\ + temp_F $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ ] + tcl::dict::set argdata_cache $cache_key $argdata_dict if {$is_dynamic} { #also cache resolved version tcl::dict::set argdata_cache $optionspecs $argdata_dict } - #tcl::dict::set argdefcache_by_id $spec_id $optionspecs - tcl::dict::set argdefcache_by_id $spec_id $args + #tcl::dict::set argdefcache_by_id $DEF_definition_id $optionspecs + tcl::dict::set argdefcache_by_id $DEF_definition_id $args #puts "xxx:$result" return $argdata_dict } - proc get_spec {id {patternlist *}} { + lappend PUNKARGS [list -dynamic 0 { + @id -id ::punk::args::get_spec + @cmd -name punk::args::get_definition -help\ + "" + id -type string -help\ + "identifer for punk::args defintion + This will usually be a fully-qualifed + path for a command name" + patternlist -type list -optional 1 -default * -help\ + "glob-style patterns for retrieving value or switch + definitions. If ommitted or passed an empty string, + the raw unresolved definition will be returned as + a list, including possible leading flags such as + -dynamic 0|1. + If specified as * - the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + " + override_dict -type dict -optional 1 -default "" -help\ + "unimplemented. + Will allow overriding or adding flags to a returned + definition line. + " + }] + #rename get_definition ??? + proc get_spec {id args} { + lassign $args patternlist override_dict + if {[llength $args] > 2} { + punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args] + return + } + if {[llength $override_dict] % 2 != 0} { + #malformed dict + punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args] + return + } + variable argdefcache_by_id set realid [real_id $id] if {$realid ne ""} { - if {$patternlist eq "*"} { - #todo? + if {$patternlist eq ""} { + #return the raw definition - possibly with unresolved dynamic parts return [tcl::dict::get $argdefcache_by_id $realid] } else { - set speclist [tcl::dict::get $argdefcache_by_id $realid] + set deflist [tcl::dict::get $argdefcache_by_id $realid] set result "" - set specdict [uplevel 1 [list ::punk::args::definition {*}$speclist]] - set arg_info [dict get $specdict arg_info] + set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]] + set arg_info [dict get $specdict ARG_INFO] foreach pat $patternlist { + if {[string match $pat @id]} { + #only a single id record can exist + append result \n "@id -id [dict get $specdict id]" + } + if {[string match $pat @cmd]} { + #only a single @cmd record can exist + #merged if multiple in original def (?) + append result \n "@cmd [dict get $specdict cmd_info]" + } + #todo @leaders, @opts, @values lines + #can be multiple of each. We need to preserve order and interleave + #with any matching arg_info results. + #requires storing more info in the internal spec dictionary set matches [dict keys $arg_info $pat] foreach m $matches { set def [dict get $arg_info $m] @@ -1250,9 +1607,9 @@ tcl::namespace::eval punk::args { set realid [real_id $id] if {$realid ne ""} { set speclist [tcl::dict::get $argdefcache_by_id $realid] - set specdict [definition {*}$speclist] - set arg_info [dict get $specdict arg_info] - set valnames [dict get $specdict val_names] + set specdict [define {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] set result "" if {$patternlist eq "*"} { foreach v $valnames { @@ -1280,7 +1637,7 @@ tcl::namespace::eval punk::args { proc get_def {id} { if {[id_exists $id]} { - return [definition {*}[get_spec $id]] + return [define {*}[get_spec $id]] } } proc is_dynamic {id} { @@ -1374,8 +1731,8 @@ tcl::namespace::eval punk::args { #puts -nonewline stderr . ;#debugging - see actual loads if {![catch { if {[info exists ${pkgns}::PUNKARGS]} { - foreach deflist [set ${pkgns}::PUNKARGS] { - namespace eval $pkgns [list punk::args::definition {*}$deflist] + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $pkgns [list punk::args::define {*}$definitionlist] } } if {[info exists ${pkgns}::PUNKARGS_aliases]} { @@ -1432,9 +1789,113 @@ tcl::namespace::eval punk::args { return $cmdinfo } + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::get_spec ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -choices {nocolour info error} + }] ] + #basic recursion blocker variable arg_error_isrunning 0 proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + if {[catch {package require punk::ansi}]} { proc punk::args::a {args} {} proc punk::args::a+ {args} {} @@ -1458,8 +1919,9 @@ tcl::namespace::eval punk::args { set badarg "" set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error + set scheme error dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return} $k] + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] switch -- $fullk { -badarg { set badarg $v @@ -1471,6 +1933,9 @@ tcl::namespace::eval punk::args { } set as_error $v } + -scheme { + set scheme $v + } -return { if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { set arg_error_isrunning 0 @@ -1484,6 +1949,68 @@ tcl::namespace::eval punk::args { } } } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. @@ -1510,13 +2037,13 @@ tcl::namespace::eval punk::args { append errmsg \n } else { if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)[a]" \n } else { append errmsg \n } } - set procname [Dict_getdef $spec_dict cmd_info -name ""] - set prochelp [Dict_getdef $spec_dict cmd_info -help ""] + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] set docurl [Dict_getdef $spec_dict doc_info -url ""] @@ -1531,18 +2058,18 @@ tcl::namespace::eval punk::args { set blank_header_col [list] - if {$procname ne ""} { + if {$cmdname ne ""} { lappend blank_header_col "" - set procname_display [a+ brightwhite]$procname[a] + set cmdname_display $CLR(cmdname)$cmdname[a] } else { - set procname_display "" + set cmdname_display "" } - if {$prochelp ne ""} { + if {$cmdhelp ne ""} { lappend blank_header_col "" - #set prochelp_display [a+ brightwhite]$prochelp[a] - set prochelp_display [textblock::ansibase_lines $prochelp [a+ white]] + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] } else { - set prochelp_display "" + set cmdhelp_display "" } if {$docurl ne ""} { lappend blank_header_col "" @@ -1550,11 +2077,25 @@ tcl::namespace::eval punk::args { } else { set docurl_display "" } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + if {$argdisplay_header ne ""} { lappend blank_header_col "" } if {$use_table} { - set t [textblock::class::table new [a+ brightyellow]Usage[a]] + set t [textblock::class::table new $CLR(title)Usage[a]] $t add_column -headers $blank_header_col -minwidth 3 $t add_column -headers $blank_header_col @@ -1573,19 +2114,19 @@ tcl::namespace::eval punk::args { } } set h 0 - if {$procname ne ""} { + if {$cmdname ne ""} { if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list PROC/METHOD: $procname_display] + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] } else { - lappend errlines "PROC/METHOD: $procname_display" + lappend errlines "COMMAND: $cmdname_display" } incr h } - if {$prochelp ne ""} { + if {$cmdhelp ne ""} { if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $prochelp_display] + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] } else { - lappend errlines "Description: $prochelp_display" + lappend errlines "Description: $cmdhelp_display" } incr h } @@ -1600,6 +2141,17 @@ tcl::namespace::eval punk::args { } incr h } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + if {$use_table} { if {$is_custom_argdisplay} { if {$argdisplay_header ne ""} { @@ -1632,11 +2184,13 @@ tcl::namespace::eval punk::args { set RST [a] #set A_DEFAULT [a+ brightwhite Brightgreen] set A_DEFAULT "" - set A_BADARG [a+ brightred] - set greencheck [a+ brightgreen]\u2713[a] ;#green tick - set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX [a+ green] ;#use a+ so colour off can apply - if {$A_PREFIX eq ""} { + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713[a] ;#green tick + set soloflag $CLR(solo)\u2690[a] ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead set A_PREFIX [a+ underline] set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space } else { @@ -1645,14 +2199,14 @@ tcl::namespace::eval punk::args { set opt_names [list] set opt_names_display [list] - if {[llength [dict get $spec_dict opt_names]]} { + 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 trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] set idents [dict get [$trie shortest_idents ""] scanned] #todo - check opt_prefixdeny $trie destroy - foreach c [dict get $spec_dict opt_names] { + foreach c [dict get $spec_dict OPT_NAMES] { set id [dict get $idents $c] #REVIEW if {$id eq $c} { @@ -1668,12 +2222,12 @@ tcl::namespace::eval punk::args { lappend opt_names $c } } else { - set opt_names [dict get $spec_dict opt_names] + set opt_names [dict get $spec_dict OPT_NAMES] set opt_names_display $opt_names } } - set leading_val_names [dict get $spec_dict leader_names] - set trailing_val_names [dict get $spec_dict val_names] + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { # if {![string match -* $argname]} { @@ -1695,7 +2249,7 @@ tcl::namespace::eval punk::args { lassign $argumentset argnames_display argnames foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict arg_info $arg] + set arginfo [dict get $spec_dict ARG_INFO $arg] if {[dict exists $arginfo -default]} { set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { @@ -1707,6 +2261,13 @@ tcl::namespace::eval punk::args { set choicegroups [Dict_getdef $arginfo -choicegroups {}] set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } if {[dict exists $choicegroups ""]} { dict lappend choicegroups "" {*}$choices } else { @@ -1827,12 +2388,11 @@ tcl::namespace::eval punk::args { #TODO -title directly in list_as_table set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] lappend choicetable_objects $choicetableobj - $choicetableobj configure -title [a+ cyan]$groupname + $choicetableobj configure -title $CLR(groupname)$groupname #append help \n[textblock::join -- " " [$choicetableobj print]] } else { if {$groupname ne ""} { - #bold as well as brightcolour in case colour off. - append help \n \n "[a+ brightyellow bold]Group: $groupname[a]" + append help \n \n "$CLR(groupname)Group: $groupname[a]" } else { append help \n } @@ -1846,15 +2406,15 @@ tcl::namespace::eval punk::args { if {$usetable} { #these will be displayed after all table entries if {$groupname eq ""} { - dict set choicetable_footers "" " [a+ red](no choices defined for main group)[a]" + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)[a]" } else { - dict set choicetable_footers $groupname " [a+ red](no choices defined for group $groupname)[a]" + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)[a]" } } else { if {$groupname eq ""} { - append help \n " " [a+ red](no choices defined)[a] + append help \n " " $CLR(errormsg)(no choices defined)[a] } else { - append help \n " " [a+ red](no choices defined for group $groupname)[a] + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)[a] } } } @@ -1896,13 +2456,16 @@ tcl::namespace::eval punk::args { } } } - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - set argshow "?${argshow}?" + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } } set typeshow [dict get $arginfo -type] if {$typeshow eq "none"} { @@ -1936,7 +2499,13 @@ tcl::namespace::eval punk::args { } ;#end is_custom_argdisplay if {$use_table} { - $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + $t configure -maxwidth 80 ;#review if {$returntype ne "tableobject"} { append errmsg [$t print] @@ -1976,7 +2545,7 @@ tcl::namespace::eval punk::args { } - lappend PUNKARGS [list { + lappend PUNKARGS [list -dynamic 1 { @id -id ::punk::args::usage @cmd -name punk::args::usage -help\ "Return usage information for a command. @@ -1989,6 +2558,7 @@ tcl::namespace::eval punk::args { mechanism and call this as necessary. " -return -default table -choices {string table tableobject} + } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} { @values -min 0 -max 1 id -help\ @@ -1998,11 +2568,12 @@ tcl::namespace::eval punk::args { proc usage {args} { lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received set id [dict get $values id] - set speclist [get_spec $id] - if {[llength $speclist] == 0} { + set definitionlist [get_spec $id] + if {[llength $definitionlist] == 0} { error "punk::args::usage - no such id: $id" } - arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] {*}$opts -aserror 0 + #by placing scheme before the supplied args - it can be overridden + arg_error "" [uplevel 1 [list punk::args::define {*}$definitionlist]] -scheme punk_info {*}$opts -aserror 0 } lappend PUNKARGS [list { @@ -2010,16 +2581,150 @@ tcl::namespace::eval punk::args { @cmd -name punk::args::get_by_id @values -min 1 id - arglist -default "" -type list -help\ + arglist -type list -help\ "list containing arguments to be parsed as per the argument specification identified by the supplied id." }] - proc get_by_id {id {arglist ""}} { - set speclist [punk::args::get_spec $id] - if {[llength $speclist] == 0} { + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::get_spec $id] + if {[llength $definitionlist] == 0} { error "punk::args::get_by_id - no such id: $id" } - return [uplevel 1 [list ::punk::args::get_dict {*}$speclist $arglist]] + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing + record that has been created with ::punk::args::define. + In the 'withdef' form - the definition is created on the + first call and cached thereafter. + + form1: parse ?-flag val?... -- $arglist withid $id + form2: parse ?-flag val?... -- $arglist withdef $def ?$def? + see punk::args::define" + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries. + " + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard minimal} + @values -min 3 + sep -optional 0 -choices "--" + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + set split [lsearch -exact $args --] ;#first -- + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. End of opts marker -- is required even if no options are present." + } + set opts [lrange $args 0 $split-1] ;#repeated flags will override earlier. That's ok here. + set arglist [lindex $args $split+1] + set tailtype [lindex $args $split+2] + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $args $split+3 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $split+3] + return "parse [llength $arglist] args withid $id, options:$opts" + } + withdef { + if {[llength [lrange $args $split+3 end]] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO } #todo? - a version of get_dict that directly supports punk::lib::tstr templating @@ -2031,6 +2736,15 @@ tcl::namespace::eval punk::args { #only supports -flag val pairs, not solo options #If an option is supplied multiple times - only the last value is used. proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + #*** !doctools #[call [fun get_dict] [arg optionspecs] [arg rawargs]] #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values @@ -2065,54 +2779,26 @@ tcl::namespace::eval punk::args { # @values -multiple 1 #} $args - #if {[llength $args] == 0} { - # set rawargs [list] - #} elseif {[llength $args] ==1} { - # set rawargs [lindex $args 0] ;#default tcl style - #} else { - # #todo - can we support tk style vals before flags? - # #the aim is to allow a single call to validate standard leading proc positional args along with the $args val which may have flags in tk or tcl order - # #by allowing all to be in a single call - we could use a -help (or similar erroring call) to trigger the spec-parsing from a wrapper function. - # #this would be important in the case where the function to be wrapped has never been called - but the wrapper needs info about the downstream options - # #we would like to avoid the ugliness of trying to parse a proc body to scrape the specification. - # #we may still need to do a basic scan of the proc body to determine if it at least contains the string punk::args::get_dict - but that is slightly less odious. - # error "unsupported number of arguments for punk::args::get_dict" - # set inopt 0 - # set k "" - # set i 0 - # foreach a $args { - # switch -- $f { - # -opts { - - # } - # -vals { - - # } - # -optvals { - # #tk style - - # } - # -valopts { - # #tcl style - # set rawargs [lindex $args $i+1] - # incr i - # } - # default { - - # } - # } - # incr i - # } - #} set is_dynamic 0 if {[lindex $args 0] eq "-dynamic"} { set is_dynamic [lindex $args 1] } set rawargs [lindex $args end] ;# args values to be parsed - set def_args [lrange $args 0 end-1] - set argspecs [uplevel 1 [list ::punk::args::definition {*}$def_args]] + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::define {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + #puts "-arg_info->$arg_info" set flagsreceived [list] ;#for checking if required flags satisfied #secondary purpose: @@ -2128,31 +2814,31 @@ tcl::namespace::eval punk::args { set opts $opt_defaults set pre_values {} - set argnames [tcl::dict::keys $arg_info] + set argnames [tcl::dict::keys $ARG_INFO] set optnames [lsearch -all -inline $argnames -*] set ridx 0 set rawargs_copy $rawargs set leader_posn_name "" set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) set is_multiple 0 ;#last leader may be multi - if {$leader_max != 0} { + if {$LEADER_MAX != 0} { foreach r $rawargs_copy { - if {$leader_max ne "" && $leader_max != -1 && $ridx > $leader_max-1} { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { break } - if {$ridx == [llength $leader_names]-1} { + if {$ridx == [llength $LEADER_NAMES]-1} { #at last named leader - set leader_posn_name [lindex $leader_names $ridx] - if {[dict exists $arg_info $leader_posn_name -multiple] && [dict get $arg_info $leader_posn_name -multiple]} { + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { set is_multiple 1 } - } elseif {$ridx > [llength $leader_names]-1} { + } elseif {$ridx > [llength $LEADER_NAMES]-1} { #beyond names - retain name if -multiple was true if {!$is_multiple} { set leader_posn_name "" } } else { - set leader_posn_name [lindex $leader_names $ridx] ;#may return empty string + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string } if {$r eq "--"} { #review end of opts marker: '--' can't be a leader (but can be a value) @@ -2181,7 +2867,7 @@ tcl::namespace::eval punk::args { #for each branch - break or lappend if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $leader_required} { + if {$leader_posn_name ni $LEADER_REQUIRED} { #optional leader #most adhoc arg processing will allocate based on number of args rather than matching choice values first @@ -2220,11 +2906,11 @@ tcl::namespace::eval punk::args { } } else { #unnamed leader - if {$leader_min ne "" } { - if {$ridx > $leader_min} { + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { break } else { - #haven't reached leader_min + #haven't reached LEADER_MIN lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } @@ -2234,16 +2920,24 @@ tcl::namespace::eval punk::args { } incr ridx - } + } ;# end foreach r $rawargs_copy } - if {$leader_min eq ""} { - set leader_min 0 + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN } - if {$leader_max eq ""} { - set leader_max -1 + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX } - #assert leader_max leader_min are numeric + #assert leadermax leadermin are numeric #assert - rawargs has been reduced by leading positionals set leaders [list] @@ -2251,7 +2945,7 @@ tcl::namespace::eval punk::args { set post_values {} #val_min, val_max #puts stderr "rawargs: $rawargs" - #puts stderr "arg_info: $arg_info" + #puts stderr "argstate: $argstate" if {[lsearch $rawargs -*] >= 0} { #at least contains flaglike things.. set maxidx [expr {[llength $rawargs] -1}] @@ -2298,9 +2992,9 @@ tcl::namespace::eval punk::args { } break } else { - set fullopt [tcl::prefix match -error "" $opt_names $a] + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] if {$fullopt ne ""} { - if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { #non-solo #check if it was actually a value that looked like a flag if {$i == $maxidx} { @@ -2312,7 +3006,7 @@ tcl::namespace::eval punk::args { } set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $argstate $fullopt -multiple]} { #don't lappend to default - we need to replace if there is a default if {$fullopt ni $flagsreceived} { tcl::dict::set opts $fullopt [list $flagval] @@ -2329,7 +3023,7 @@ tcl::namespace::eval punk::args { } } else { #solo - if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $argstate $fullopt -multiple]} { if {$fullopt ni $flagsreceived} { #override any default - don't lappend to it tcl::dict::set opts $fullopt 1 @@ -2359,10 +3053,10 @@ tcl::namespace::eval punk::args { if {$opt_any} { set newval [lindex $rawargs $i+1] #opt was unspecified but is allowed due to @opts -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::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { tcl::dict::lappend opts $a $newval } else { tcl::dict::set opts $a $newval @@ -2373,7 +3067,7 @@ tcl::namespace::eval punk::args { 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::get $argstate $a -multiple]} { if {![tcl::dict::exists $opts $a]} { tcl::dict::set opts $a 1 } else { @@ -2386,8 +3080,8 @@ tcl::namespace::eval punk::args { } lappend flagsreceived $a ;#adhoc flag as supplied } else { - if {[llength $opt_names]} { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" + if {[llength $OPT_NAMES]} { + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" } else { set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" } @@ -2419,15 +3113,15 @@ tcl::namespace::eval punk::args { set ldridx 0 set in_multiple "" set leadernames_received [list] - set leaders_dict $leader_defaults + set leaders_dict $LEADER_DEFAULTS set num_leaders [llength $leaders] - foreach leadername $leader_names ldr $leaders { + foreach leadername $LEADER_NAMES ldr $leaders { if {$ldridx+1 > $num_leaders} { break } if {$leadername ne ""} { - if {[tcl::dict::get $arg_info $leadername -multiple]} { - if {[tcl::dict::exists $leader_defaults $leadername]} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list } else { tcl::dict::lappend leaders_dict $leadername $ldr @@ -2443,8 +3137,8 @@ tcl::namespace::eval punk::args { lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) } else { tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set arg_info $positionalidx $leaderspec_defaults - tcl::dict::set arg_checks $positionalidx $leader_checks_defaults + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS lappend leadernames_received $positionalidx } } @@ -2457,12 +3151,12 @@ tcl::namespace::eval punk::args { set valnames_received [list] set values_dict $val_defaults set num_values [llength $values] - foreach valname $val_names val $values { + foreach valname $VAL_NAMES val $values { if {$validx+1 > $num_values} { break } if {$valname ne ""} { - if {[tcl::dict::get $arg_info $valname -multiple]} { + if {[tcl::dict::get $argstate $valname -multiple]} { if {[tcl::dict::exists $val_defaults $valname]} { #current stored val equals defined default - don't include default in the list we build up tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list @@ -2481,8 +3175,8 @@ tcl::namespace::eval punk::args { lappend valnames_received $in_multiple } else { tcl::dict::set values_dict $positionalidx $val - tcl::dict::set arg_info $positionalidx $valspec_defaults - tcl::dict::set arg_checks $positionalidx $val_checks_defaults + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS lappend valnames_received $positionalidx } } @@ -2490,17 +3184,17 @@ tcl::namespace::eval punk::args { incr positionalidx } - if {$leader_max == -1} { + if {$leadermax == -1} { #only check min - if {$num_leaders < $leader_min} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leader_min" $argspecs + if {$num_leaders < $leadermin} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs } } else { - if {$num_leaders < $leader_min || $num_leaders > $leader_max} { - if {$leader_min == $leader_max} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leader_min" $argspecs + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs } else { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leader_min and $leader_max inclusive" $argspecs + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs } } } @@ -2541,7 +3235,7 @@ tcl::namespace::eval punk::args { # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $leader_required $leadernames_received]]]} { + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs } if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { @@ -2560,9 +3254,9 @@ tcl::namespace::eval punk::args { set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash #puts "---opts_and_values:$opts_and_values" - #puts "---arg_info:$arg_info" + #puts "---argstate:$argstate" tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $arg_info $argname] + set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] set thisarg_checks [tcl::dict::get $arg_checks $argname] set is_multiple [tcl::dict::get $thisarg -multiple] @@ -3471,10 +4165,10 @@ tcl::namespace::eval punk::args::lib { #for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. #arguably it may be more processor-cache-efficient to do together like this anyway. -#can't do this - as there is circular dependency with punk::lib +#can't do this here? - as there is circular dependency with punk::lib #tcl::namespace::eval punk::args { # foreach deflist $PUNKARGS { -# punk::args::definition {*}$deflist +# punk::args::define {*}$deflist # } # set PUNKARGS "" #} diff --git a/src/bootsupport/modules/punk/char-0.1.0.tm b/src/bootsupport/modules/punk/char-0.1.0.tm index 3024053b..8cb06b1f 100644 --- a/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/bootsupport/modules/punk/char-0.1.0.tm @@ -1246,6 +1246,10 @@ tcl::namespace::eval punk::char { return [charset_dict "Box Drawing"] } + proc char_hex {char} { + return [format %08x [scan $char %c]] + } + proc char_info_hex {hex args} { set hex [tcl::string::map [list _ ""] $hex] if {[tcl::string::is xdigit -strict $hex]} { diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index d2c08e8b..74365afa 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -1186,7 +1186,7 @@ namespace eval punk::console { #todo - change -inoutchannels to -terminalobject with prebuilt default - punk::args::definition { + punk::args::define { @id -id ::punk::console::cell_size -inoutchannels -default {stdin stdout} -type list @values -min 0 -max 1 diff --git a/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/bootsupport/modules/punk/fileline-0.1.0.tm index 6de20bff..1f02859b 100644 --- a/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -1251,7 +1251,7 @@ namespace eval punk::fileline { #[para] Core API functions for punk::fileline #[list_begin definitions] - punk::args::definition { + punk::args::define { @id -id ::punk::fileline::get_textinfo @cmd -name punk::fileline::get_textinfo -help\ "return: textinfo object instance" diff --git a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index f427f29f..b5539021 100644 --- a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -26,7 +26,7 @@ package require punk::lib namespace eval punk::mix::commandset::loadedlib { namespace export * #search automatically wrapped in * * - can contain inner * ? globs - punk::args::definition { + punk::args::define { @id -id ::punk::mix::commandset::loadedlib::search @cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" -return -type string -default table -choices {table tableobject list lines} diff --git a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index 2079eb8c..41206d0c 100644 --- a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -141,7 +141,7 @@ namespace eval punk::mix::commandset::module { set moduletypes [punk::mix::cli::lib::module_types] - punk::args::definition [subst { + punk::args::define [subst { @id -id ::punk::mix::commandset::module::new @cmd -name "punk::mix::commandset::module::new" -help\ "Create a new module file in the appropriate folder within src/modules. 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 3f5f3a71..5d601b3a 100644 --- a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -636,7 +636,7 @@ tcl::namespace::eval punk::nav::fs { # c:/repo/jn/punk/../../blah #dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold # dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream - punk::args::definition { + punk::args::define { @id -id ::punk::nav::fs::dirfiles -stripbase -default 1 -type boolean -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" @@ -992,7 +992,7 @@ tcl::namespace::eval punk::nav::fs { return [dict merge $listing $updated] } - punk::args::definition { + punk::args::define { @id -id ::punk::nav::fs::dirfiles_dict_as_lines -stripbase -default 0 -type boolean -formatsizes -default 1 -type boolean diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm index f8a1e939..6235224a 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -1893,7 +1893,31 @@ tcl::namespace::eval punk::ns { } } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} $vline" set idauto "(autodef)$origin" - set argspec [punk::lib::tstr -return string { + set argdef [punk::lib::tstr -return string { @id -id ${$idauto} @cmd -name "Object: ${$origin}" -help\ "Instance of class: ${$class} (info autogenerated)" @values -min 1 }] - append argspec \n $vline - punk::args::definition $argspec + append argdef \n $vline + punk::args::define $argdef return [punk::args::usage {*}$opts $idauto] } privateObject { @@ -2457,7 +2502,8 @@ tcl::namespace::eval punk::ns { set match [tcl::prefix::match $subcommands [lindex $queryargs 0]] if {$match in $subcommands} { set subcmd [dict get $subcommand_dict $match] - return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + return [arginfo {*}$opts {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") } } @@ -2491,15 +2537,15 @@ tcl::namespace::eval punk::ns { set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] set autoid "(autodef)$origin" - set argspec [punk::lib::tstr -return string { + set argdef [punk::lib::tstr -return string { @id -id ${$autoid} @cmd -help\ "(autogenerated) ensemble: ${$origin}" @values -min 1 }] - append argspec \n $vline - punk::args::definition $argspec + append argdef \n $vline + punk::args::define $argdef return [punk::args::usage {*}$opts $autoid] } @@ -2918,7 +2964,7 @@ tcl::namespace::eval punk::ns { } interp alias "" use "" punk::ns::pkguse - punk::args::definition { + punk::args::define { @id -id ::punk::ns::nsimport_noclobber @cmd -name punk::ns::nsimport_noclobber -help\ "Import exported commands from a namespace into either the current namespace, diff --git a/src/bootsupport/modules/punk/path-0.1.0.tm b/src/bootsupport/modules/punk/path-0.1.0.tm index 65ede7c8..ede3e18b 100644 --- a/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/bootsupport/modules/punk/path-0.1.0.tm @@ -644,7 +644,7 @@ namespace eval punk::path { return $ismatch } - punk::args::definition { + punk::args::define { @id -id ::punk::path::treefilenames -directory -type directory -help\ "folder in which to begin recursive scan for files." diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index 98bc04ef..063a13c0 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -65,6 +65,22 @@ namespace eval punk::repo { variable PUNKARGS variable PUNKARGS_aliases + variable cached_command_paths + set cached_command_paths [dict create] + #anticipating possible removal of buggy caching from auto_execok + #mentioned in: https://core.tcl-lang.org/tcl/tktview/4dc35e0c0c + #this would leave the application to decide what it wants to cache in that regard. + proc Cached_auto_execok {name} { + return [auto_execok $name] + #variable cached_command_paths + #if {[dict exists $cached_command_paths $name]} { + # return [dict get $cached_command_paths $name] + #} + #set resolved [auto_execok $name] + #dict set cached_command_paths $name $resolved + #return $resolved + } + proc get_fossil_usage {} { set allcmds [runout -n fossil help -a] set mainhelp [runout -n fossil help] @@ -197,7 +213,7 @@ namespace eval punk::repo { #emit warning whether or not multiple fossil repos puts stdout [dict get $repostate warnings] } - set fossil_prog [auto_execok fossil] + set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog ne ""} { {*}$fossil_prog {*}$args } else { @@ -222,7 +238,10 @@ namespace eval punk::repo { #uppercase FOSSIL to bypass fossil as alias to fossil_proxy + #only necessary on unix? + #Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway proc establish_FOSSIL {args} { + #review if {![info exists ::auto_execs(FOSSIL)]} { set ::auto_execs(FOSSIL) [auto_execok fossil] ;#may fail in safe interp } @@ -499,7 +518,7 @@ namespace eval punk::repo { #For this reason we will store 'unchanged' records for both git and fossil so that the combined dict should represent all files in the revision if {$rt eq "fossil"} { dict set resultdict repotype fossil - set fossil_cmd [auto_execok fossil] + set fossil_cmd [Cached_auto_execok fossil] if {$fossil_cmd eq ""} { error "workingdir_state error: fossil executable doesn't seem to be available" } @@ -598,7 +617,7 @@ namespace eval punk::repo { break } elseif {$rt eq "git"} { dict set resultdict repotype git - set git_cmd [auto_execok git] + set git_cmd [Cached_auto_execok git] # -uno = suppress ? lines. # -b = show ranch and tracking info #our basic parsing/grepping assumes --porcelain=2 @@ -988,7 +1007,7 @@ namespace eval punk::repo { } proc fossil_get_repository_file {{path {}}} { if {$path eq {}} { set path [pwd] } - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set fossilinfo [::exec {*}$fossilcmd info] @@ -1073,7 +1092,7 @@ namespace eval punk::repo { set startdir $opt_parentfolder - set fossil_prog [auto_execok fossil] + set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog eq ""} { puts stderr "Fossil not found. Please install fossil" return @@ -1319,7 +1338,7 @@ namespace eval punk::repo { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[Cached_auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } @@ -1332,7 +1351,7 @@ namespace eval punk::repo { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[Cached_auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } @@ -1343,7 +1362,7 @@ namespace eval punk::repo { proc fossil_revision {{path {}}} { if {$path eq {}} { set path [pwd] } # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set info [::exec {*}$fossilcmd info] @@ -1357,7 +1376,7 @@ namespace eval punk::repo { proc fossil_remote {{path {}}} { if {$path eq {}} { set path [pwd] } # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set info [::exec {*}$fossilcmd remote ls] @@ -1423,7 +1442,7 @@ namespace eval punk::repo { set original_cwd [pwd] #attempt2 - let fossil do it for us - hopefully based on current folder if {$path eq {}} {set path [pwd]} - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {![llength $fossilcmd]} { set fossil_ok 0 } else { diff --git a/src/bootsupport/modules/textblock-0.1.2.tm b/src/bootsupport/modules/textblock-0.1.2.tm index dcc023ec..a3d5b967 100644 --- a/src/bootsupport/modules/textblock-0.1.2.tm +++ b/src/bootsupport/modules/textblock-0.1.2.tm @@ -8367,7 +8367,7 @@ tcl::namespace::eval textblock { foreach tline $tlines { if {[tcl::string::first $FSUB $tline] >= 0} { set content_line [lindex $clines $contentindex] - if {[tcl::string::first $R $content_line] == 0} { + if {[tcl::string::first $R [string range $content_line 0 10]] == 0} { set content_line [tcl::string::range $content_line $rlen end] } #make sure to replay opt_ansibase to the right of the replacement diff --git a/src/bootsupport/modules/textblock-0.1.3.tm b/src/bootsupport/modules/textblock-0.1.3.tm new file mode 100644 index 00000000..32450e55 --- /dev/null +++ b/src/bootsupport/modules/textblock-0.1.3.tm @@ -0,0 +1,8567 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix 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. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application textblock 0.1.3 +# Meta platform tcl +# Meta license +# @@ Meta End + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_textblock 0 0.1.3] +#[copyright "2024"] +#[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 ansi text layout colour table frame console terminal] +#[description] +#[para] Ansi-aware terminal textblock manipulation + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of textblock +#[subsection Concepts] +#[para] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by textblock +#[list_begin itemized] + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] +#[item] [package {punk::char}] +#[item] [package {punk::ansi}] +#[item] [package {punk::lib}] +#[item] [package {overtype}] +#[item] [package {term::ansi::code::macros}] +#[item] [package {textutil}] + +## Requirements +package require Tcl 8.6- +package require punk::args +package require punk::char +package require punk::ansi +package require punk::lib +catch {package require patternpunk} +package require overtype + +#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. +if {[catch { + package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? +} errM]} { + #catch this too in case stderr not available + catch { + puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM" + } +} +package require textutil + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval textblock { + #review - what about ansi off in punk::console? + tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ + tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock + + #NOTE sha1, although computationally more intensive, tends to be faster than md5 on modern cpus + #(more likely to be optimised for modern cpu features?) + #(This speed improvement may not apply for short strings) + + variable use_hash ;#framecache + set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display + #if {![catch {package require sha1}]} { + # set use_hash sha1 + #} elseif {![catch {package require md5}]} { + # set use_hash md5 + #} else { + # set use_hash none + #} + + proc use_hash {args} { + set choices [list none] + set unavailable [list] + set pkgs [package names] + if {"md5" in $pkgs} { + lappend choices md5 + } else { + lappend unavailable md5 + } + if {"sha1" in $pkgs} { + lappend choices sha1 + } else { + lappend unavailable sha1 + } + set choicemsg "" + if {[llength $unavailable]} { + set choicemsg " (unavailable packages: $unavailable)" + } + set argd [punk::args::get_dict [tstr -return string { + @id -id ::textblock::use_hash + @cmd -name "textblock::use_hash" -help\ + "Hashing algorithm to use for framecache lookup. + 'none' may be slightly faster but less compact + when viewing textblock::framecache" + @values -min 0 -max 1 + hash_algorithm -choices {${$choices}} -optional 1 -help\ + "algorithm choice ${$choicemsg}" + }] $args] + variable use_hash + if {![dict exists $argd received hash_algorithm]} { + return $use_hash + } + set use_hash [dict get $argd values hash_algorithm] + } + tcl::namespace::eval class { + variable opts_table_defaults + set opts_table_defaults [tcl::dict::create\ + -title ""\ + -titlealign "left"\ + -titletransparent 0\ + -frametype "light"\ + -frametype_header ""\ + -ansibase_header ""\ + -ansibase_body ""\ + -ansibase_footer ""\ + -ansiborder_header ""\ + -ansiborder_body ""\ + -ansiborder_footer ""\ + -ansireset "\uFFeF"\ + -framelimits_header "vll vlr hlb hlt tlc trc blc brc"\ + -frametype_body ""\ + -framelimits_body "vll vlr hlb hlt tlc trc blc brc"\ + -framemap_body [list\ + topleft {} topinner {} topright {} topsolo {}\ + middleleft {} middleinner {} middleright {} middlesolo {}\ + bottomleft {} bottominner {} bottomright {} bottomsolo {}\ + onlyleft {} onlyinner {} onlyright {} onlysolo {}\ + ]\ + -framemap_header [list\ + topleft {} topinner {} topright {} topsolo {}\ + middleleft {} middleinner {} middleright {} middlesolo {}\ + bottomleft {} bottominner {} bottomright {} bottomsolo {}\ + onlyleft {} onlyinner {} onlyright {} onlysolo {}\ + ]\ + -show_edge 1\ + -show_seps 1\ + -show_hseps ""\ + -show_vseps ""\ + -show_header ""\ + -show_footer ""\ + -minwidth ""\ + -maxwidth ""\ + ] + variable opts_column_defaults + set opts_column_defaults [tcl::dict::create\ + -headers [list]\ + -header_colspans [list]\ + -footers [list]\ + -defaultvalue ""\ + -ansibase ""\ + -ansireset "\uFFEF"\ + -minwidth ""\ + -maxwidth ""\ + -blockalign centre\ + -textalign left\ + ] + #initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only + + + + #for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns) + #ie only vll,blc,hlb used for cells except top row and right column + #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) + #right cells use 'U' shape (vll,blc,hlb,brc,vlr) + #e.g for 4x4 + # C C C O + # L L L U + # L L L U + #anti-clockwise elements + set C [list hlt tlc vll blc hlb] + set O [list trc hlt tlc vll blc hlb brc vlr] + set L [list vll blc hlb] + set U [list vll blc hlb brc vlr] + set tops [list trc hlt tlc] + set lefts [list tlc vll blc] + set bottoms [list blc hlb brc] + set rights [list trc brc vlr] + + variable table_edge_parts + set table_edge_parts [tcl::dict::create\ + topleft [struct::set intersect $C [concat $tops $lefts]]\ + 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]\ + middleinner [list]\ + middleright [struct::set intersect $U $rights]\ + middlesolo [struct::set intersect $U [concat $lefts $rights]]\ + bottomleft [struct::set intersect $L [concat $lefts $bottoms]]\ + bottominner [struct::set intersect $L $bottoms]\ + bottomright [struct::set intersect $U [concat $bottoms $rights]]\ + bottomsolo [struct::set intersect $U [concat $lefts $bottoms $rights]]\ + onlyleft [struct::set intersect $C [concat $tops $lefts $bottoms]]\ + onlyinner [struct::set intersect $C [concat $tops $bottoms]]\ + onlyright [struct::set intersect $O [concat $tops $bottoms $rights]]\ + onlysolo [struct::set intersect $O [concat $tops $lefts $bottoms $rights]]\ + ] + + #for header rows - we don't consider the bottom border as part of the edge - even if table body has no rows + #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 [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 [list {*}$lefts {*}$rights]]\ + bottomleft [struct::set intersect $L $lefts]\ + bottominner [list]\ + bottomright [struct::set intersect $U $rights]\ + 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 [list {*}$tops {*}$rights]]\ + onlysolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ + ] + variable table_hseps + set table_hseps [tcl::dict::create\ + topleft [list blc hlb]\ + topinner [list blc hlb]\ + topright [list blc hlb brc]\ + topsolo [list blc hlb brc]\ + middleleft [list blc hlb]\ + middleinner [list blc hlb]\ + middleright [list blc hlb brc]\ + middlesolo [list blc hlb brc]\ + bottomleft [list]\ + bottominner [list]\ + bottomright [list]\ + bottomsolo [list]\ + onlyleft [list]\ + onlyinner [list]\ + onlyright [list]\ + onlysolo [list]\ + ] + variable table_vseps + set table_vseps [tcl::dict::create\ + topleft [list]\ + topinner [list vll tlc blc]\ + topright [list vll tlc blc]\ + topsolo [list]\ + middleleft [list]\ + middleinner [list vll tlc blc]\ + middleright [list vll tlc blc]\ + middlesolo [list]\ + bottomleft [list]\ + bottominner [list vll tlc blc]\ + bottomright [list vll tlc blc]\ + bottomsolo [list]\ + onlyleft [list]\ + onlyinner [list vll tlc blc]\ + onlyright [list vll tlc blc]\ + onlysolo [list]\ + ] + + #ensembles seem to be not compiled in safe interp + #https://core.tcl-lang.org/tcl/tktview/1095bf7f75 + #as we want textblock to be usable in safe interps - use tcl::dict::for as a partial workaround + #This at least means the script argument, especially switch statements can get compiled. + #It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp. + + #e.g $t configure -framemap_body [table_edge_map " "] + + # -- --- --- --- --- + #unused? + proc table_edge_map {char} { + variable table_edge_parts + set map [list] + tcl::dict::for {celltype parts} $table_edge_parts { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + proc table_sep_map {char} { + variable table_hseps + set map [list] + tcl::dict::for {celltype parts} $table_hseps { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + proc header_edge_map {char} { + variable header_edge_parts + set map [list] + tcl::dict::for {celltype parts} $header_edge_parts { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + # -- --- --- --- --- + + if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} { + #*** !doctools + #[subsection {Namespace textblock::class}] + #[para] class definitions + #[list_begin itemized] [comment {- textblock::class groupings -}] + # [item] + # [para] [emph {handler_classes}] + # [list_begin enumerated] + + #this makes new table objects a little faster when multiple opts specified as well as to configure + #as tables are a heavyweight thing, but handy to nest sometimes - we'll take what we can get + set topt_keys [tcl::dict::keys $::textblock::class::opts_table_defaults] + set switch_keys_valid_topts [punk::lib::lmapflat v $topt_keys {list $v -}] + set switch_keys_valid_topts [lrange $switch_keys_valid_topts 0 end-1] ;#remove last dash + + set copt_keys [tcl::dict::keys $::textblock::class::opts_column_defaults] + set switch_keys_valid_copts [punk::lib::lmapflat v $copt_keys {list $v -}] + 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. + + variable o_columndefs + variable o_columndata + variable o_columnstates + variable o_headerdefs + variable o_headerstates + + variable o_rowdefs + variable o_rowstates + + variable o_opts_table_defaults + variable o_opts_header_defaults ;# header data mostly stored in o_columndefs + variable o_opts_column_defaults + variable o_opts_row_defaults + variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap) + variable o_calculated_column_widths + variable o_column_width_algorithm + + + 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 + + + if {[llength $args] == 1} { + set args [list -title [lindex $args 0]] + } + if {[llength $args] %2 !=0} { + error "[tcl::namespace::current]::table constructor - unexpected argument count. Require single value being title, or name value pairs" + } + + set o_opts_table $o_opts_table_defaults + set o_opts_table_effective $o_opts_table_defaults + + ##todo - test with punk::lib::show_jump_tables - how? + foreach {k v} $args { + switch -- $k { + %topt_switchkeys% { + tcl::dict::set o_opts_table $k $v + } + default { + error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + } + + #foreach {k v} $args { + # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. + # if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { + # error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + # } + #} + #set o_opts_table [tcl::dict::merge $o_opts_table_defaults $args] + #my configure {*}[tcl::dict::merge $o_opts_table_defaults $args] + + set o_columndefs [tcl::dict::create] + set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row + set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly + set o_headerdefs [tcl::dict::create] ;#by header-row + set o_headerstates [tcl::dict::create] + set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight + set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data + + set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices. + set o_calculated_column_widths [list] + set o_column_width_algorithm "span" + set o_opts_header_defaults [tcl::dict::create\ + -colspans {}\ + -values {}\ + -ansibase {}\ + -ansireset "\x1b\[m"\ + -minheight 1\ + -maxheight ""\ + ] + my configure {*}$o_opts_table + } + + method width_algorithm {{alg ""}} { + if {$alg eq ""} { + return $o_column_width_algorithm + } + if {$alg ne $o_column_width_algorithm} { + #invalidate cached widths + set o_calculated_column_widths [list] + } + set o_column_width_algorithm $alg + } + method Get_seps {} { + set requested_seps [tcl::dict::get $o_opts_table -show_seps] + set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] + set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] + set seps $requested_seps + set seps_h $requested_seps_h + set seps_v $requested_seps_v + if {$requested_seps eq ""} { + if {$requested_seps_h eq ""} { + set seps_h 1 + } + if {$requested_seps_v eq ""} { + set seps_v 1 + } + } else { + if {$requested_seps_h eq ""} { + set seps_h $seps + } + if {$requested_seps_v eq ""} { + set seps_v $seps + } + } + return [tcl::dict::create horizontal $seps_h vertical $seps_v] + } + method Get_frametypes {} { + set requested_ft [tcl::dict::get $o_opts_table -frametype] + set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] + set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] + set ft $requested_ft + set ft_header $requested_ft_header + set ft_body $requested_ft_body + switch -- $requested_ft { + light { + if {$requested_ft_header eq ""} { + set ft_header heavy + } + if {$requested_ft_body eq ""} { + 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 + } + if {$requested_ft_body eq ""} { + set ft_body $requested_ft + } + } + } + return [tcl::dict::create header $ft_header body $ft_body] + } + method Set_effective_framelimits {} { + upvar ::textblock::class::opts_table_defaults tdefaults + set default_blims [tcl::dict::get $tdefaults -framelimits_body] + set default_hlims [tcl::dict::get $tdefaults -framelimits_header] + set eff_blims [tcl::dict::get $o_opts_table_effective -framelimits_body] + set eff_hlims [tcl::dict::get $o_opts_table_effective -framelimits_header] + + set requested_blims [tcl::dict::get $o_opts_table -framelimits_body] + set requested_hlims [tcl::dict::get $o_opts_table -framelimits_header] + set blims $eff_blims + set hlims $eff_hlims + switch -- $requested_blims { + "default" { + set blims $default_blims + } + default { + #set blims $requested_blims + set blims [list] + foreach lim $requested_blims { + switch -- $lim { + hl { + lappend blims hlt hlb + } + vl { + lappend blims vll vlr + } + default { + lappend blims $lim + } + } + } + set blims [lsort -unique $blims] + } + } + tcl::dict::set o_opts_table_effective -framelimits_body $blims + switch -- $requested_hlims { + "default" { + set hlims $default_hlims + } + default { + #set hlims $requested_hlims + set hlims [list] + foreach lim $requested_hlims { + switch -- $lim { + hl { + lappend hlims hlt hlb + } + vl { + lappend hlims vll vlr + } + default { + lappend hlims $lim + } + } + } + set hlims [lsort -unique $hlims] + } + } + tcl::dict::set o_opts_table_effective -framelimits_header $hlims + 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 + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [list %topt_keys%]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_opts_table $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { + tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "[tcl::namespace::current]::table configure - unexpected argument count. Require name value pairs" + } + foreach {k v} $args { + switch -- $k { + %topt_switchkeys% {} + default { + error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + #if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { + # error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + #} + } + set checked_opts [list] + foreach {k v} $args { + switch -- $k { + -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set ansi_codes [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend ansi_codes $code + } + } + set ansival [punk::ansi::codetype::sgr_merge_singles $ansi_codes] + lappend checked_opts $k $ansival + } + -frametype - -frametype_header - -frametype_body { + #frametype will raise an error if v is not a valid custom dict or one of the known predefined types such as light,heavy,double etc + lassign [textblock::frametype $v] _cat category _type ftype + lappend checked_opts $k $v + } + -framemap_body - -framemap_header { + #upvar ::textblock::class::opts_table_defaults tdefaults + #set default_bmap [tcl::dict::get $tdefaults -framemap_body] + #todo - check keys and map + if {[llength $v] == 1} { + if {$v eq "default"} { + upvar ::textblock::class::opts_table_defaults tdefaults + set default_map [tcl::dict::get $tdefaults $k] + lappend checked_opts $k $default_map + } else { + error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}" + } + } else { + #safe jumptable test + #dict for {subk subv} $v {} + foreach {subk subv} $v { + switch -- $subk { + topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} + default { + error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" + } + } + #safe jumptable test + #dict for {seg subst} $subv {} + foreach {seg subst} $subv { + switch -- $seg { + hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {} + default { + error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}" + } + } + } + + } + lappend checked_opts $k $v + } + + } + -framelimits_body - -framelimits_header { + set specific_framelimits [list] + foreach fl $v { + switch -- $fl { + "default" { + lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr + } + hl { + lappend specific_framelimits hlt hlb + } + vl { + lappend specific_framelimits vll vlr + } + hlt - hlb - vll - vlr - trc - tlc - blc - brc { + lappend specific_framelimits $fl + } + default { + error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)" + } + } + } + lappend checked_opts $k $specific_framelimits + } + -ansireset { + if {$v eq "\uFFEF"} { + set RST "\x1b\[m" ;#[a] + lappend checked_opts $k $RST + } else { + error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -show_hseps { + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + lappend checked_opts $k $v + #these don't affect column width calculations + } + -show_edge { + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + lappend checked_opts $k $v + #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + } + -show_vseps { + #we allow empty string - so don't use -strict boolean check + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + #affects width calculations + set o_calculated_column_widths [list] + lappend checked_opts $k $v + } + -minwidth - -maxwidth { + set o_calculated_column_widths [list] + lappend checked_opts $k $v + } + default { + lappend checked_opts $k $v + } + } + } + #all options checked - ok to update o_opts_table and o_opts_table_effective + + #set o_opts_table [tcl::dict::merge $o_opts_table $checked_opts] + foreach {k v} $args { + switch -- $k { + -framemap_header - -framemap_body { + #framemaps don't require setting every key to update. + #e.g configure -framemaps {topleft } + #needs to merge with existing unspecified keys such as topright middleleft etc. + if {$v eq "default"} { + tcl::dict::set o_opts_table $k default + } else { + if {[tcl::dict::get $o_opts_table $k] eq "default"} { + tcl::dict::set o_opts_table $k $v + } else { + tcl::dict::set o_opts_table $k [tcl::dict::merge [tcl::dict::get $o_opts_table $k] $v] + } + } + } + -title { + set twidth [punk::ansi::printing_length $v] + if {[my width] < [expr {$twidth+2}]} { + set o_calculated_column_widths [list] + tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] + } + tcl::dict::set o_opts_table -title $v + } + default { + tcl::dict::set o_opts_table $k $v + } + } + } + #use values from checked_opts for the effective opts + #safe jumptable test + #dict for {k v} $checked_opts {} + #foreach {k v} $checked_opts {} + tcl::dict::for {k v} $checked_opts { + switch -- $k { + -framemap_body - -framemap_header { + set existing [tcl::dict::get $o_opts_table_effective $k] + #set updated $existing + #dict for {subk subv} $v { + # tcl::dict::set updated $subk $subv + #} + #tcl::dict::set o_opts_table_effective $k $updated + tcl::dict::set o_opts_table_effective $k [tcl::dict::merge $existing $v] + } + -framelimits_body - -framelimits_header { + #my Set_effective_framelimits + tcl::dict::set o_opts_table_effective $k $v + } + default { + tcl::dict::set o_opts_table_effective $k $v + } + } + } + #ansireset exception + tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] + return $o_opts_table + } + + #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] + if {$table_colcount == 0} { + for {set c 0} {$c < $matrix_colcount} {incr c} { + my add_column -headers "" + } + } + set table_colcount [my column_count] + if {$table_colcount != $matrix_colcount} { + error "textblock::table::printmatrix column count of table doesn't match column count of matrix" + } + if {[my row_count] > 0} { + my row_clear + } + for {set r 0} {$r < $matrix_rowcount} {incr r} { + my add_row [$matrix get row $r] + } + 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 { + set m [struct::matrix $cmd] + } + $m add columns [tcl::dict::size $o_columndata] + $m add rows [tcl::dict::size $o_rowdefs] + tcl::dict::for {k v} $o_columndata { + $m set column $k $v + } + return $m + } + method add_column {args} { + #*** !doctools + #[call class::table [method add_column] [arg args]] + + + if {[llength $args] %2 != 0} { + error "[tcl::namespace::current]::table::add_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" + } + set opts $o_opts_column_defaults + foreach {k v} $args { + switch -- $k { + %copt_switchkeys% { + tcl::dict::set opts $k $v + } + default { + error "[tcl::namespace::current]::table::add_column unknown option '$k'. Known options: %copt_keys%" + } + } + } + set colcount [tcl::dict::size $o_columndefs] + + + tcl::dict::set o_columndata $colcount [list] + #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists + tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists + + + tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] + set prev_calculated_column_widths $o_calculated_column_widths + if {[catch { + my configure_column $colcount {*}$opts + } errMsg]} { + #configure failed - ensure o_columndata and o_columndefs entries are removed + tcl::dict::unset o_columndata $colcount + tcl::dict::unset o_columndefs $colcount + tcl::dict::unset o_columnstates $colcount + #undo cache invalidation + set o_calculated_column_widths $prev_calculated_column_widths + error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" + } + #any add_column that succeeds should invalidate the calculated column widths + set o_calculated_column_widths [list] + set numrows [my row_count] + if {$numrows > 0} { + #fill column with default values + #puts ">>> adding default values for column $colcount" + set dval [tcl::dict::get $opts -defaultvalue] + set width [textblock::width $dval] + tcl::dict::set o_columndata $colcount [lrepeat $numrows $dval] + tcl::dict::set o_columnstates $colcount maxwidthbodyseen $width + tcl::dict::set o_columnstates $colcount minwidthbodyseen $width + } + 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" + } + if {![llength $args]} { + return [tcl::dict::get $o_columndefs $cidx] + } else { + if {[llength $args] == 1} { + if {[lindex $args 0] in [list %copt_keys%]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_columndefs $cidx $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + } else { + error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values %copt_keys%" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" + } + foreach {k v} $args { + switch -- $k { + %copt_switchkeys% {} + default { + error "[tcl::namespace::current]::table configure_column unknown option '$k'. Known options: %copt_keys%" + } + } + } + set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state + + set hstates $o_headerstates ;#operate on a copy + set colstate [tcl::dict::get $o_columnstates $cidx] + set args_got_headers 0 + set args_got_header_colspans 0 + foreach {k v} $args { + switch -- $k { + -headers { + set args_got_headers 1 + set i 0 + set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. + foreach hdr $v { + set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns + #set this_header_height [textblock::height $hdr] + lassign [textblock::size $hdr] _w this_header_width _h this_header_height + + if {$this_header_height >= $currentmax} { + tcl::dict::set hstates $i maxheightseen $this_header_height + } else { + tcl::dict::set hstates $i maxheightseen $currentmax + } + if {$this_header_width >= $maxseen} { + set maxseen $this_header_width + } + #if {$this_header_width > [tcl::dict::get $colstate maxwidthheaderseen]} { + # tcl::dict::set colstate maxwidthheaderseen $this_header_width + #} + incr i + } + tcl::dict::set colstate maxwidthheaderseen $maxseen + #review - we could avoid some recalcs if we check current width range compared to previous + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -header_colspans { + set args_got_header_colspans 1 + #check columns to left to make sure each new colspan for this column makes sense in the overall context + #user may have to adjust colspans in order left to right to avoid these check errors + #note that 'any' represents span all up to the next non-zero defined colspan. + set cspans [my header_colspans] + set h 0 + if {[llength $v] > [tcl::dict::size $cspans]} { + error "configure_column $cidx -header_colspans. Only [tcl::dict::size $cspans] headers exist. Too many values supplied" + } + foreach s $v { + if {$cidx == 0} { + if {[tcl::string::is integer -strict $s]} { + if {$s < 1} { + error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'any' or a positive integer" + } + } else { + if {$s ne "any" && $s ne ""} { + error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" + } + } + } else { + #if {![tcl::string::is integer -strict $s]} { + # if {$s ne "any" && $s ne ""} { + # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" + # } + #} else { + set header_spans [tcl::dict::get $cspans $h] + set remaining [lindex $header_spans 0] + if {$remaining ne "any"} { + incr remaining -1 + } + #look at spans defined for previous cols + #we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption + for {set c 0} {$c < $cidx} {incr c} { + set span [lindex $header_spans $c] + if {$span eq "any"} { + set remaining "any" + } else { + if {$remaining eq "any"} { + if {$span ne "0"} { + #a previous column has ended the 'any' span + set remaining [expr {$span -1}] + } + } else { + if {$span eq "0"} { + incr remaining -1 + } else { + set remaining [expr {$span -1}] + } + #allow to go negative + } + } + } + if {$remaining eq "any"} { + #any int >0 ok - what about 'any' immediately following any? + } else { + if {$remaining > 0} { + if {$s ne "0" && $s ne ""} { + error "configure_column $cidx -header_colspans bad span $s for header '$h'. Remaining span is '$remaining' - so a zero colspan is required" + } + } else { + if {$s == 0} { + error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" + } + } + } + #} + } + incr h + } + #todo - avoid recalc if no change + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -minwidth { + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -maxwidth { + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set col_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend col_ansibase_items $code + } + } + set col_ansibase [punk::ansi::codetype::sgr_merge_singles $col_ansibase_items] + tcl::dict::set checked_opts $k $col_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + tcl::dict::set checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -blockalign - -textalign { + switch -- $v { + left - right { + tcl::dict::set checked_opts $k $v + } + centre - centre { + tcl::dict::set checked_opts $k centre + } + } + } + default { + tcl::dict::set checked_opts $k $v + } + } + } + #args checked - ok to update headerstates, headerdefs and columndefs and columnstates + tcl::dict::set o_columndefs $cidx $checked_opts + set o_headerstates $hstates + dict for {hidx hstate} $hstates { + #configure_header + if {![dict exists $o_headerdefs $hidx]} { + #remove calculated members -values -colspans + set hdefaults [dict remove $o_opts_header_defaults -values -colspans] + dict set o_headerdefs $hidx $hdefaults + } + } + + tcl::dict::set o_columnstates $cidx $colstate + + if {$args_got_headers} { + #if the headerlist length for this column has shrunk,and it was the longest - we may now have excess entries in o_headerstates + set zero_heights [list] + tcl::dict::for {hidx _v} $o_headerstates { + #pass empty string for exclude_column so we don't exclude our own column + if {[my header_height_calc $hidx ""] == 0} { + lappend zero_heights $hidx + } + } + foreach zidx $zero_heights { + tcl::dict::unset o_headerstates $zidx + } + } + if {$args_got_headers || $args_got_header_colspans} { + #check and adjust header_colspans for all columns + + } + + return [tcl::dict::get $o_columndefs $cidx] + } + } + + 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 {} { + set max_headers 0 + tcl::dict::for {k cdef} $o_columndefs { + set num_headers [llength [tcl::dict::get $cdef -headers]] + set max_headers [expr {max($max_headers,$num_headers)}] + } + 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] + } + + #review - use maxwidth (considering colspans) of each column to determine height after wrapping + # -need to consider whether vertical expansion allowed / maxheight? + method header_height_calc {header_index {exclude_column ""}} { + set dataheight 0 + if {$exclude_column eq ""} { + set exclude_colidx "" + } else { + set exclude_colidx [lindex [tcl::dict::keys $o_columndefs] $exclude_column] + } + tcl::dict::for {cidx cdef} $o_columndefs { + if {$exclude_colidx == $cidx} { + continue + } + set headerlist [tcl::dict::get $cdef -headers] + if {$header_index < [llength $headerlist]} { + set this_height [textblock::height [lindex $headerlist $header_index]] + set dataheight [expr {max($dataheight,$this_height)}] + } + } + return $dataheight + } + + #return a dict keyed on header index with values representing colspans + #e.g + # 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] + tcl::dict::for {cidx cdef} $o_columndefs { + set headerlist [tcl::dict::get $cdef -headers] + set colspans_for_column [tcl::dict::get $cdef -header_colspans] + for {set h 0} {$h < $num_headers} {incr h} { + set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] + set defined_span [lindex $colspans_for_column $h] + set i 0 + set spanremaining [lindex $headerspans 0] + if {$spanremaining ne "any"} { + if {$spanremaining eq ""} { + set spanremaining 1 + } + incr spanremaining -1 + } + foreach s $headerspans { + if {$s eq "any"} { + set spanremaining "any" + } elseif {$s == 0} { + if {$spanremaining ne "any"} { + incr spanremaining -1 + } + } else { + set spanremaining [expr {$s - 1}] + } + incr i + } + if {$defined_span eq ""} { + if {$spanremaining eq "0"} { + lappend headerspans 1 + } else { + #"any" or an integer + lappend headerspans 0 + } + } else { + lappend headerspans $defined_span + } + tcl::dict::set colspans_by_header $h $headerspans + } + } + return $colspans_by_header + } + + #e.g + # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 any 1} 3 {any 0 0 1} + #convert to + # 0 {4 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} + method header_colspans_numeric {} { + set hcolspans [my header_colspans] + if {![tcl::dict::size $hcolspans]} { + return + } + set numcols [llength [tcl::dict::get $hcolspans 0]] ;#assert: all are the same + tcl::dict::for {h spans} $hcolspans { + set c 0 ;#column index + foreach s $spans { + if {$s eq "any"} { + set spanlen 1 + for {set i [expr {$c+1}]} {$i < $numcols} {incr i} { + #next 'any' or non-zero ends an 'any' span + if {[lindex $spans $i] ne "0"} { + break + } + incr spanlen + } + #overwrite the 'any' with it's actual span + set modified_spans [dict get $hcolspans $h] + lset modified_spans $c $spanlen + dict set hcolspans $h $modified_spans + } + incr c + } + } + return $hcolspans + } + + method configure_header {index_expression args} { + #*** !doctools + #[call class::table [method configure_header]] + #[para] - configure header row-wise + + #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} + set num_headers [my header_count_calc] + set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression] + if {$hidx eq ""} { + error "textblock::table::configure_header - no header row defined at index '$index_expression'." + } + if {$hidx > $num_headers -1} { + #assert - shouldn't happen + error "textblock::table::configure_header error headerstates data is out of sync" + } + + if {![llength $args]} { + set colspans_by_header [my header_colspans] + set result [tcl::dict::create] + tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] + set header_row_items [list] + tcl::dict::for {cidx cdef} $o_columndefs { + set colheaders [tcl::dict::get $cdef -headers] + set relevant_header [lindex $colheaders $hidx] + #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + } + tcl::dict::set result -values $header_row_items + + #review - ensure always a headerdef record for each header? + if {[tcl::dict::exists $o_headerdefs $hidx]} { + set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]] + } else { + #warn for now + puts stderr "no headerdef record for header $hidx" + } + return $result + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [tcl::dict::keys $o_opts_header_defaults]} { + #query single option + set k [lindex $args 0] + #set val [tcl::dict::get $o_rowdefs $ridx $k] + + set infodict [tcl::dict::create] + #todo + # -blockalignments and -textalignments lists + # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} + #if there is a value it overrides alignments specified on the column + switch -- $k { + -values { + set header_row_items [list] + tcl::dict::for {cidx cdef} $o_columndefs { + set colheaders [tcl::dict::get $cdef -headers] + set relevant_header [lindex $colheaders $hidx] + #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + + } + set val $header_row_items + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + } + -colspans { + set colspans_by_header [my header_colspans] + set result [tcl::dict::create] + set val [tcl::dict::get $colspans_by_header $hidx] + #ansireset not required + set returndict [tcl::dict::create option $k value $val] + } + -ansibase { + set val ??? + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_header_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_header_defaults]" + } + foreach {k v} $args { + if {$k ni [tcl::dict::keys $o_opts_header_defaults]} { + error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_header_defaults]" + } + } + + set checked_opts [list] + #safe jumptable test + #dict for {k v} $args {} + foreach {k v} $args { + switch -- $k { + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set header_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend header_ansibase_items $code + } + } + set header_ansibase [punk::ansi::codetype::sgr_merge_singles $header_ansibase_items] + lappend checked_opts $k $header_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + lappend checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -values { + if {[llength $v] > [tcl::dict::size $o_columndefs]} { + error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" + } + lappend checked_opts $k $v + } + -colspans { + set numcols [tcl::dict::size $o_columndefs] + if {[llength $v] > $numcols} { + error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" + } + if {[llength $v] < $numcols} { + puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." + puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" + } + if {[llength $v]} { + set firstspan [lindex $v 0] + set first_is_ok 0 + if {$firstspan eq "any"} { + set first_is_ok 1 + } elseif {[tcl::string::is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} { + set first_is_ok 1 + } + if {!$first_is_ok} { + error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" + } + #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) + set remaining $firstspan + if {$remaining ne "any"} { + incr remaining -1 + } + set spanview $v + set sidx 1 + #because we allow 'any' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'any' first + foreach span [lrange $v 1 end] { + if {$remaining eq "any"} { + if {$span eq "any"} { + set remaining "any" + } elseif {$span > 0} { + #ok to reset to higher val immediately or after an any and any number of following zeros + if {$span > ($numcols - $sidx)} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" + } + set remaining $span + incr remaining -1 + } else { + #zero following an any - leave remaining as any + } + } else { + if {$span eq "0"} { + if {$remaining eq "0"} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" + } else { + incr remaining -1 + } + } else { + if {$remaining eq "0"} { + #ok for new span value of any or > 0 + if {$span ne "any" && $span > ($numcols - $sidx)} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" + } + set remaining $span + if {$remaining ne "any"} { + incr remaining -1 + } + } else { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" + } + } + } + incr sidx + } + } + #empty -colspans list should be ok + + #error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now" + lappend checked_opts $k $v + } + default { + lappend checked_opts $k $v + } + } + } + + #configured opts all good + #safe jumptable test + #dict for {k v} $checked_opts {} + #foreach {k v} $checked_opts {} + + # headerdefs excludes -values and -colspans + set update_hdefs [tcl::dict::get $o_headerdefs $hidx] + + tcl::dict::for {k v} $checked_opts { + switch -- $k { + -values { + set c 0 + foreach hval $v { + #retrieve -headers from relevant col, insert at header index, and write back. + set thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers] + set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}] + if {$missing > 0} { + lappend thiscol_headers_vertical {*}[lrepeat $missing ""] + } + lset thiscol_headers_vertical $hidx $hval + tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical + #invalidate column width cache + set o_calculated_column_widths [list] + # -- -- -- -- -- -- + #also update maxwidthseen & maxheightseen + set i 0 + set maxwidthseen 0 + #set maxheightseen 0 + foreach hdr $thiscol_headers_vertical { + lassign [textblock::size $hdr] _w this_header_width _h this_header_height + set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0] + if {$this_header_height >= $maxheightseen} { + tcl::dict::set o_headerstates $i maxheightseen $this_header_height + } else { + tcl::dict::set o_headerstates $i maxheightseen $maxheightseen + } + if {$this_header_width >= $maxwidthseen} { + set maxwidthseen $this_header_width + } + incr i + } + tcl::dict::set o_columnstates $c maxwidthheaderseen $maxwidthseen + # -- -- -- -- -- -- + incr c + } + } + -colspans { + #sequence has been verified above - we need to split it and store across columns + set c 0 ;#column index + foreach span $v { + set colspans [tcl::dict::get $o_columndefs $c -header_colspans] + if {$hidx > [llength $colspans]-1} { + set colspans_by_header [my header_colspans] + #puts ">>>>>?$colspans_by_header" + #we are allowed to lset only one beyond the current length to append + #but there may be even less or no entries present in a column + # - the ability to underspecify and calculate the missing values makes setting the values complicated. + #use the header_colspans calculation to update only those entries necessary + set spanlist [list] + for {set h 0} {$h < $hidx} {incr h} { + set cspans [tcl::dict::get $colspans_by_header $h] + set requiredval [lindex $cspans $c] + lappend spanlist $requiredval + } + tcl::dict::set o_columndefs $c -header_colspans $spanlist + + set colspans [tcl::dict::get $o_columndefs $c -header_colspans] + } + + lset colspans $hidx $span + tcl::dict::set o_columndefs $c -header_colspans $colspans + incr c + } + } + default { + dict set update_hdefs $k $v + } + } + } + set opt_minh [tcl::dict::get $update_hdefs -minheight] + set opt_maxh [tcl::dict::get $update_hdefs -maxheight] + + #todo - allow zero values to hide/collapse + # - see also configure_row + if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { + error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" + } + if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { + error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" + } + if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { + error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" + } + + #set o_headerstate $hidx -minheight? -maxheight? ??? + tcl::dict::set o_headerdefs $hidx $update_hdefs + } + + method add_row {valuelist args} { + #*** !doctools + #[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 + append msg "rowdata: $valuelist" + error $msg + } + if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { + error "add_row - no values supplied, and no columns defined, so cannot use default column values" + } + + set defaults [tcl::dict::create\ + -minheight 1\ + -maxheight ""\ + -ansibase ""\ + -ansireset "\uFFEF"\ + ] + set o_opts_row_defaults $defaults + + if {[llength $args] %2 !=0} { + error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" + } + #safe jumptable test + #dict for {k v} $args {} + foreach {k v} $args { + switch -- $k { + -minheight - -maxheight - -ansibase - -ansireset {} + default { + error "Invalid option '$k' Known options: [tcl::dict::keys $defaults] (-ansireset is read-only)" + } + } + } + set opts [tcl::dict::merge $defaults $args] + + set auto_columns 0 + if {[tcl::dict::size $o_columndefs] == 0} { + set auto_columns 1 + #no columns defined - auto define with defaults for each column in first supplied row + #auto define columns only valid if no existing columns + #the autocolumns must be added before configure_row - but if configure_row fails - we need to remove them! + foreach el $valuelist { + my add_column + } + } else { + if {![llength $valuelist]} { + tcl::dict::for {k coldef} $o_columndefs { + lappend valuelist [tcl::dict::get $coldef -defaultvalue] + } + } + } + set rowcount [tcl::dict::size $o_rowdefs] + tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure + + if {[catch { + my configure_row $rowcount {*}$opts + } errMsg]} { + #undo anything we saved before configure_row + tcl::dict::unset o_rowdefs $rowcount + #remove auto_columns + if {$auto_columns} { + set o_columndata [tcl::dict::create] + set o_columndefs [tcl::dict::create] + set o_columnstate [tcl::dict::create] + } + error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" + } + + + set c 0 + set max_height_seen 1 + foreach v $valuelist { + set prev_maxwidth [tcl::dict::get $o_columnstates $c maxwidthbodyseen] + set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] + + tcl::dict::lappend o_columndata $c $v + lassign [textblock::size_as_list $v] valwidth valheight + if {$valheight > $max_height_seen} { + set max_height_seen $valheight + } + if {$valwidth > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { + tcl::dict::set o_columnstates $c maxwidthbodyseen $valwidth + } + 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} { + #invalidate calculated column width cache if any new value was outside the previous range of widths + set o_calculated_column_widths [list] + } + incr c + } + + set opt_maxh [tcl::dict::get $o_rowdefs $rowcount -maxheight] + if {$opt_maxh ne ""} { + tcl::dict::set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}] + } else { + tcl::dict::set o_rowstates $rowcount -maxheight $max_height_seen + } + + 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" + } + if {![llength $args]} { + return [tcl::dict::get $o_rowdefs $ridx] + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [tcl::dict::keys $o_opts_row_defaults]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_rowdefs $ridx $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_row_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_row_defaults]" + } + foreach {k v} $args { + if {$k ni [tcl::dict::keys $o_opts_row_defaults]} { + error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_row_defaults]" + } + } + set checked_opts [list] + foreach {k v} $args { + switch -- $k { + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set row_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend row_ansibase_items $code + } + } + set row_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] + lappend checked_opts $k $row_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + lappend checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_row -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + default { + lappend checked_opts $k $v + } + } + } + + set current_opts [tcl::dict::get $o_rowdefs $ridx] + set opts [tcl::dict::merge $current_opts $checked_opts] + + #check minheight and maxheight together + set opt_minh [tcl::dict::get $opts -minheight] + set opt_maxh [tcl::dict::get $opts -maxheight] + + #todo - allow zero values to hide/collapse rows as is possible with columns + if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { + error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" + } + if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { + error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" + } + if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { + error "[tcl::namespace::current]::table::configure_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" + } + tcl::dict::set o_rowstates $ridx -minheight $opt_minh + + + 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 + tcl::dict::for {cidx records} $o_columndata { + tcl::dict::set o_columndata $cidx [list] + #reset only the body fields in o_columnstates + tcl::dict::set o_columnstates $cidx minwidthbodyseen 0 + tcl::dict::set o_columnstates $cidx maxwidthbodyseen 0 + } + 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] + set o_columnstates [tcl::dict::create] + } + + + + #method Get_columns_by_name {namematch_list} { + #} + + #specify range with x..y + method Get_columns_by_indices {index_list} { + foreach spec $index_list { + if {[tcl::string::is integer -strict $c]} { + set colidx $c + } else { + tcl::dict::for {colidx coldef} $o_columndefs { + #if {[tcl::string::match x x]} {} + } + } + } + } + method Get_boxlimits_and_joins {position fname_body} { + #fname_body will be "custom" or one of the predefined types light,heavy etc + switch -- $position { + left { + return [tcl::dict::create \ + boxlimits [list hlb blc vll]\ + boxlimits_top [list hlb blc vll hlt tlc]\ + joins [list down]\ + bodyjoins [list down-$fname_body]\ + ] + } + inner { + return [tcl::dict::create \ + boxlimits [list hlb blc vll]\ + boxlimits_top [list hlb blc vll hlt tlc]\ + joins [list down left]\ + bodyjoins [list left down-$fname_body] + ] + } + right { + return [tcl::dict::create \ + boxlimits [list hlb blc vll vlr brc]\ + boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ + joins [list down left]\ + bodyjoins [list left down-$fname_body]\ + ] + } + solo { + return [tcl::dict::create \ + boxlimits [list hlb blc vll vlr brc]\ + boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ + joins [list down]\ + bodyjoins [list down-$fname_body]\ + ] + } + default { + error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo" + } + } + } + method Get_boxlimits_and_joins1 {position fname_body} { + #fname_body will be "custom" or one of the predefined types light,heavy etc + switch -- $position { + left { + #set header_boxlimits {hlb hlt tlc blc vll} + set header_body_joins [list down-$fname_body] + set boxlimits_position [list hlb blc vll] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] + set boxlimits_toprow [list hlb blc vll hlt tlc] + set joins [list down] + } + inner { + #set header_boxlimits {hlb hlt tlc blc vll} + set header_body_joins [list left down-$fname_body] + set boxlimits_position [list hlb blc vll] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] + set boxlimits_toprow [list hlb blc vll hlt tlc] + set joins [list down left] + } + right { + #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} + set header_body_joins [list left down-$fname_body] + set boxlimits_position [list hlb blc vll vlr brc] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] + set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] + set joins [list down left] + } + solo { + #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} + set header_body_joins [list down-$fname_body] + set boxlimits_position [list hlb blc vll vlr brc] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] + set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] + set joins [list down] + } + } + return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ] + } + method get_column_by_index {index_expression args} { + #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" + #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. + set opts [tcl::dict::create\ + -position "inner"\ + -return "string"\ + ] + foreach {k v} $args { + switch -- $k { + -position - -return { + tcl::dict::set opts $k $v + } + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid option '$k'. Known options [tcl::dict::keys $opts]" + } + } + } + set opt_posn [tcl::dict::get $opts -position] + set opt_return [tcl::dict::get $opts -return] + + switch -- $opt_posn { + left - inner - right - solo {} + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo]" + } + } + switch -- $opt_return { + string - dict {} + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_return' for -return. Valid values: string dict" + } + } + + set columninfo [my get_column_cells_by_index $index_expression] + set header_list [tcl::dict::get $columninfo headers] + #puts "===== header_list: $header_list" + set cells [tcl::dict::get $columninfo cells] + + set topt_show_header [tcl::dict::get $o_opts_table -show_header] + if {$topt_show_header eq ""} { + set allheaders 0 + set all_cols [tcl::dict::keys $o_columndefs] + foreach c $all_cols { + incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] + } + if {$allheaders == 0} { + set do_show_header 0 + } else { + set do_show_header 1 + } + } else { + set do_show_header $topt_show_header + } + set topt_show_footer [tcl::dict::get $o_opts_table -show_footer] + + + set output "" + set part_header "" + set part_body "" + set part_footer "" + + set boxlimits "" + set joins "" + set header_boxlimits [list] + set header_body_joins [list] + + + set ftypes [my Get_frametypes] + set ftype_body [tcl::dict::get $ftypes body] + if {[llength $ftype_body] >= 2} { + set fname_body "custom" + } else { + set fname_body $ftype_body + } + set ftype_header [tcl::dict::get $ftypes header] + if {[llength $ftype_header] >= 2} { + set fname_header "custom" + } else { + set fname_header $ftype_header + } + + set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] + set header_body_joins [tcl::dict::get $limj bodyjoins] + set joins [tcl::dict::get $limj joins] + set boxlimits_position [tcl::dict::get $limj boxlimits] + set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] + #use struct::set instead of simple for loop - will be faster at least when critcl available + set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] + set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] + set header_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_position] + set header_boxlimits_toprow [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_toprow] + + set fmap [tcl::dict::get $o_opts_table_effective -framemap_body] + set hmap [tcl::dict::get $o_opts_table_effective -framemap_header] + + #if {![tcl::dict::get $o_opts_table -show_edge]} { + # set body_edgemap [textblock::class::table_edge_map ""] + # dict for {k v} $fmap { + # #tcl::dict::set fmap $k [tcl::dict::merge $v [tcl::dict::get $body_edgemap $k]] + # } + # set header_edgemap [textblock::class::header_edge_map ""] + # dict for {k v} $hmap { + # #tcl::dict::set hmap $k [tcl::dict::merge $v [tcl::dict::get $header_edgemap $k]] + # } + #} + set sep_elements_horizontal $::textblock::class::table_hseps + set sep_elements_vertical $::textblock::class::table_vseps + + set topmap [tcl::dict::get $fmap top$opt_posn] + set botmap [tcl::dict::get $fmap bottom$opt_posn] + set midmap [tcl::dict::get $fmap middle$opt_posn] + set onlymap [tcl::dict::get $fmap only$opt_posn] + + set hdrmap [tcl::dict::get $hmap only${opt_posn}] + + set topseps_h [tcl::dict::get $sep_elements_horizontal top$opt_posn] + set midseps_h [tcl::dict::get $sep_elements_horizontal middle$opt_posn] + set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] + set midseps_v [tcl::dict::get $sep_elements_vertical middle$opt_posn] + set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] + set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] + + #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway + set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] + + lassign [my Get_seps] _h show_seps_h _v show_seps_v + set return_headerheight 0 + set return_headerwidth 0 + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + + set colwidth [my column_width $cidx] + + set col_blockalign [tcl::dict::get $o_columndefs $cidx -blockalign] + + if {$do_show_header} { + #puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap" + set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure + set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] + if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { + set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] + set ansiborder_final $ansibase_header$ansiborder_header$extrabg + } else { + set ansiborder_final $ansibase_header$ansiborder_header + } + set RST [punk::ansi::a] + + + set hcolwidth $colwidth + #set hcolwidth [my column_width_configured $cidx] + set hcell_line_blank [tcl::string::repeat " " $hcolwidth] + + set all_colspans [my header_colspans_numeric] + + #put our framedef calls together + set fdef_header [textblock::framedef $ftype_header] + set framedef_leftbox [textblock::framedef -joins left $ftype_header] + set framedef_headerdown_same [textblock::framedef -joins {down} $ftype_header] + set framedef_headerdown_body [textblock::framedef -joins [list down-$fname_body] $ftype_header] + #default span_extend_map - used as base to customise with specific joins + set span_extend_map [tcl::dict::create \ + vll " "\ + tlc [tcl::dict::get $fdef_header hlt]\ + blc [tcl::dict::get $fdef_header hlb]\ + ] + + + #used for colspan-zero header frames + set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test + + set hrow 0 + set hmax [expr {[llength $header_list] -1}] + foreach header $header_list { + set headerspans [tcl::dict::get $all_colspans $hrow] + set this_span [lindex $headerspans $cidx] + #set hval $ansibase_header$header ;#no reset + set hval $header + set rowh [my header_height $hrow] + + if {$hrow == 0} { + set hlims $header_boxlimits_toprow + set rowpos "top" + if {$hrow == $hmax} { + set rowpos "only" + } + } else { + set hlims $header_boxlimits + set rowpos "middle" + if {$hrow == $hmax} { + set rowpos "bottom" + } + } + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {$hrow == $hmax} { + set header_joins $header_body_joins + } else { + set header_joins $joins + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + } + #puts ">>> headerspans: $headerspans cidx: $cidx" + + #if {$this_span eq "any" || $this_span > 0} {} + #changed to processing only numeric colspans + + if {$this_span > 0} { + set startmap [tcl::dict::get $hmap $rowpos${opt_posn}] + #look at spans in header below to determine joins required at blc + if {$show_seps_v} { + if {[tcl::dict::exists $all_colspans [expr {$hrow+1}]]} { + set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] + set spanbelow [lindex $next_spanlist $cidx] + if {$spanbelow == 0} { + #we don't want a down-join for blc - use a framedef with only left joins + tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] + } + } else { + set next_spanlist [list] + } + } + + #supporting wrapping in headers might be a step too difficult for little payoff. + #we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib) + #The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex. + #May be better to require user to pre-wrap as needed + ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] + + #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used + #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) + + # -width is always +2 - as the boxlimits take into account show_vseps and show_edge + #set header_cell_startspan [textblock::frame -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 $hval\ + # ] + + if {$this_span == 1} { + #write the actual value now + set cellcontents $hval + } else { + #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 -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\ + ] + + if {$this_span != 1} { + #puts "===>\n$header_cell_startspan\n<===" + set spanned_parts [list $header_cell_startspan] + #assert this_span == "any" or >1 ie a header that spans other columns + #therefore more parts to append + #set remaining_cols [lrange [tcl::dict::keys $o_columndefs] $cidx end] + set remaining_spans [lrange $headerspans $cidx+1 end] + set spanval [join $remaining_spans ""] ;#so we can test for all zeros + set spans_to_rhs 0 + if {[expr {$spanval}] == 0} { + #puts stderr "SPANS TO RHS" + set spans_to_rhs 1 + } + + #puts ">> remaining_spans: $remaining_spans" + set spancol [expr {$cidx + 1}] + set h_lines [lrepeat $rowh ""] + set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + + + + set last [expr {[llength $remaining_spans] -1}] + set i 0 + foreach s $remaining_spans { + if {$s == 0} { + if {$i == $last} { + set next_posn right + #set next_posn inner + } else { + set next_posn inner + } + + set next_headerseps_v [tcl::dict::get $sep_elements_vertical top$next_posn] ;#static top ok + + set limj [my Get_boxlimits_and_joins $next_posn $fname_body] + set span_joins_body [tcl::dict::get $limj bodyjoins] + set span_joins [tcl::dict::get $limj joins] + set span_boxlimits [tcl::dict::get $limj boxlimits] + set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] + #use struct::set instead of simple for loop - will be faster at least when critcl available + #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] + #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] + set header_span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits] + set header_span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits_top] + if {$hrow == 0} { + set hlims $header_span_boxlimits_top + } else { + set hlims $header_span_boxlimits + } + + set this_span_map $span_extend_map + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $next_headerseps_v] + } else { + if {[llength $next_spanlist]} { + set spanbelow [lindex $next_spanlist $spancol] + if {$spanbelow != 0} { + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype + } + } else { + #join to body + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype + } + } + + if {$hrow == $hmax} { + set header_joins $span_joins_body + } else { + set header_joins $span_joins + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] + } + + set contentwidth [my column_width $spancol] + set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [tcl::dict::get $ftypes header]\ + -ansibase $ansibase_header -ansiborder $ansiborder_final\ + -boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\ + ] + lappend spanned_parts $header_cell + } else { + break + } + incr spancol + incr i + } + + #JMN + #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic + set spanned_frame [textblock::join_basic -- {*}$spanned_parts] + + if {$spans_to_rhs} { + if {$cidx == 0} { + set fake_posn solo + } else { + set fake_posn right + } + set x_limj [my Get_boxlimits_and_joins $fake_posn $fname_body] + if {$hrow == 0} { + set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] + } else { + set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] + } + } else { + if {$hrow == 0} { + set hlims $header_boxlimits_toprow + } else { + set hlims $header_boxlimits + } + } + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + if {$spans_to_rhs} { + #assert fake_posn has been set above based on cidx and spans_to_rhs + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts ${rowpos}$fake_posn] ] + } else { + #use the edge_parts corresponding to the column being written to ie use opt_posn + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + } + } + + set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements + #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 -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]" + #puts "==>hval:'[ansistring VIEW $hval]'" + #set spanned_frame [overtype::renderspace -transparent 1 $spanned_frame $hblock] + + #spanned values default left - todo make configurable + + #TODO + #consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span + #we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes? + #this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span. + #(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned) + + set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] + #POTENTIAL BUG (fixed with spans_to_rhs above) + #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) + #we need to shift 1 to the left when doing our overtype with blockalign right + #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge + #(even though the column position may be left or inner) + + + + } else { + #this_span == 1 + set spanned_frame [textblock::join_basic -- $header_cell_startspan] + } + + + append part_header $spanned_frame + append part_header \n + } else { + #zero span header directly in this column ie one that is being colspanned by some column to our left + #previous col will already have built lines for this in it's own header rhs overhang + #we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent. + + #set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1] + + #if there are no header elements above then we will need a minimum of the column width + #may be extended to the widest portion of the header in the loop below + set padwidth [my column_width $cidx] + + + #under assumption we are building table using L frame method and that horizontal borders are only ever 1 high + # - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc + #avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 ) + if 0 { + #breaks -show_edge 0 + if {$rowpos eq "top" && [tcl::dict::get $o_opts_table -show_edge]} { + set padheight [expr {$rowh + 2}] + } else { + set padheight [expr {$rowh + 1}] + } + set bline [tcl::string::repeat $TSUB [expr {$padwidth +1}]] + set h_lines [lrepeat $padheight $bline] + set hcell_blank [::join $h_lines \n] + set header_frame $hcell_blank + } else { + set bline [tcl::string::repeat $TSUB $padwidth] + set h_lines [lrepeat $rowh $bline] + set hcell_blank [::join $h_lines \n] + # -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 -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ + -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ + ] + } + + append part_header $header_frame\n + + } + incr hrow + } + if {![llength $header_list]} { + #no headers - but we've been asked to show_header + #display a zero content-height header (ie outline if edge is being shown - or bottom bar) + set hlims $header_boxlimits_toprow + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + 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 -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\ + ] + append part_header $header_frame\n + } + set part_header [tcl::string::trimright $part_header \n] + lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight + + set padline [tcl::string::repeat $TSUB $return_headerwidth] + set adjusted_lines [list] + foreach ln [split $part_header \n] { + if {[tcl::string::first $TSUB $ln] >=0} { + lappend adjusted_lines $padline + } else { + lappend adjusted_lines $ln + } + } + set part_header [::join $adjusted_lines \n] + #append output $part_header \n + } + + set r 0 + set rmax [expr {[llength $cells]-1}] + + + set blims_mid $boxlimits + set blims_top $boxlimits + set blims_bot $boxlimits + set blims_top_headerless $boxlimits_headerless + set blims_only $boxlimits + set blims_only_headerless $boxlimits_headerless + if {!$show_seps_h} { + set blims_mid [struct::set difference $blims_mid $midseps_h] + set blims_top [struct::set difference $blims_top $topseps_h] + set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_h] + } + if {!$show_seps_v} { + set blims_mid [struct::set difference $blims_mid $midseps_v] + set blims_top [struct::set difference $blims_top $topseps_v] + set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_v] + set blims_bot [struct::set difference $blims_bot $botseps_v] + set blims_only [struct::set difference $blims_only $onlyseps_v] + set blims_only_headerless [struct::set difference $blims_only_headerless $onlyseps_v] + } + + set colidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range + + set opt_col_ansibase [tcl::dict::get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column + #set colwidth [my column_width $colidx] + + set body_ansibase [tcl::dict::get $o_opts_table -ansibase_body] + #set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body + set body_ansiborder [tcl::dict::get $o_opts_table -ansiborder_body] + if {[tcl::dict::get $o_opts_table -frametype] eq "block"} { + #block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled + #we need to only accept background ansi codes from the columndef ansibase for this + set col_bg [punk::ansi::codetype::sgr_merge_singles [list $opt_col_ansibase] -filter_fg 1] ;#special merge for block borders - don't override fg colours + set border_ansi $body_ansibase$body_ansiborder$col_bg + } else { + set border_ansi $body_ansibase$body_ansiborder + } + + + set r 0 + set ftblock [expr {[tcl::dict::get $o_opts_table -frametype] eq "block"}] + foreach c $cells { + #cells in column - each new c is in a different row + set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] + set row_bg "" + if {$row_ansibase ne ""} { + set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] + } + + set ansibase $body_ansibase$opt_col_ansibase + #todo - joinleft,joinright,joindown based on opts in args + set cell_ansibase "" + + set ansiborder_body_col_row $border_ansi$row_bg + set ansiborder_final $ansiborder_body_col_row + #$c will always have ansi resets due to overtype behaviour ? + #todo - review overtype + if {[punk::ansi::ta::detect $c]} { + #use only the last ansi sequence in the cell value + #Filter out foreground and use background for ansiborder override + set parts [punk::ansi::ta::split_codes_single $c] + #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt + set codes [list] + foreach {pt cd} $parts { + if {$cd ne ""} { + lappend codes $cd + } + } + #set takebg [lindex $parts end-1] + #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] + set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] + #puts --->[ansistring VIEW $codes] + + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { + #special case double reset at end of content + set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters + set ansibase "" + set row_ansibase "" + if {$ftblock} { + set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1] + } + set cell_ansibase $cell_ansi_tail + } else { + #single trailing reset in content + set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase + } + } else { + if {$ftblock} { + #no resets - use cell's bg to extend to the border - only for block frames + set ansiborder_final $ansiborder_body_col_row$cell_bg + } + set cell_ansibase $cell_bg + } + } + + set ansibase_final $ansibase$row_ansibase$cell_ansibase + + if {$r == 0} { + if {$r == $rmax} { + set joins [lremove $joins [lsearch $joins down*]] + set bmap $onlymap + if {$do_show_header} { + set blims $blims_only + } else { + set blims $blims_only_headerless + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] + } + } else { + set bmap $topmap + if {$do_show_header} { + set blims $blims_top + } else { + set blims $blims_top_headerless + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] + } + } + 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 { + if {$r == $rmax} { + set joins [lremove $joins [lsearch $joins down*]] + set bmap $botmap + set blims $blims_bot + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts bottom$opt_posn] ] + } + } else { + set bmap $midmap + set blims $blims_mid ;#will only be reduced from boxlimits if -show_seps was processed above + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] + } + } + 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 + } + #return empty (zero content height) row if no rows + if {![llength $cells]} { + set joins [lremove $joins [lsearch $joins down*]] + #we need to know the width of the column to setup the empty cell properly + #even if no header displayed - we should take account of any defined column widths + set colwidth [my column_width $index_expression] + + if {$do_show_header} { + set blims $blims_only + } else { + append part_body \n + set blims $blims_only_headerless + } + #note that if show_edge is 0 - then for this empty line - we will not expect to see any bars + #This is because the frame with no data had vertical components made entirely of corner elements + #we could just append a newline when -show_edge is zero, but we want the correct width even when empty - for proper column joins when there are colspanned headers. + # + if {![tcl::dict::get $o_opts_table -show_edge]} { + #set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] + #append output [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n + append part_body [tcl::string::repeat " " $colwidth] \n + set return_bodywidth $colwidth + } else { + 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] + } + } + #assert bodywidth is integer >=0 whether there are rows or not + + #trim only 1 newline + if {[tcl::string::index $part_body end] eq "\n"} { + set part_body [tcl::string::range $part_body 0 end-1] + } + set return_bodyheight [textblock::height $part_body] + #append output $part_body + + if {$opt_return eq "string"} { + if {$part_header ne ""} { + set output $part_header + if {$part_body ne ""} { + append output \n $part_body + } + } else { + set output $part_body + } + return $output + } else { + return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] + } + } + + 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 "" + if {[tcl::dict::size $o_columndefs] > 0} { + set range "0..[expr {[tcl::dict::size $o_columndefs] -1}]" + } else { + set range empty + } + error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" + } + #assert cidx is integer >=0 + set num_header_rows [my header_count] + set cdef [tcl::dict::get $o_columndefs $cidx] + set headerlist [tcl::dict::get $cdef -headers] + set ansibase_col [tcl::dict::get $cdef -ansibase] + set textalign [tcl::dict::get $cdef -textalign] + switch -- $textalign { + left {set pad right} + right {set pad left} + default { + set pad "centre" ;#todo? + } + } + + #set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] + #set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] + + #set header_underlay $ansibase_header$cell_line_blank + + #set hdrwidth [my column_width_configured $cidx] + #set all_colspans [my header_colspans] + #we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric + set all_colspans [my header_colspans_numeric] + #JMN + #store configured widths so we don't look up for each header line + #set configured_widths [list] + #foreach c [tcl::dict::keys $o_columndefs] { + # #lappend configured_widths [my column_width $c] + # #we don't just want the width of the column in the body - or the headers will get truncated + # lappend configured_widths [my column_width_configured $c] + #} + + set output [tcl::dict::create] + tcl::dict::set output headers [list] + + set showing_vseps [my Showing_vseps] + for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} { + set hdr [lindex $headerlist $hrow] + #jjj + set header_maxdataheight [tcl::dict::get $o_headerstates $hrow maxheightseen] + #set header_maxdataheight [my header_height $hrow] ;#from cached headerstates + set headerdefminh [tcl::dict::get $o_headerdefs $hrow -minheight] + set headerdefmaxh [tcl::dict::get $o_headerdefs $hrow -maxheight] + if {"$headerdefminh$headerdefmaxh" ne "" && $headerdefminh eq $headerdefmaxh} { + set headerh $headerdefminh ;#exact height defined for the row + } else { + if {$headerdefminh eq ""} { + if {$headerdefmaxh eq ""} { + #both defs empty + set headerh $header_maxdataheight + } else { + set headerh [expr {min(1,$headerdefmaxh,$header_maxdataheight)}] + } + } else { + if {$headerdefmaxh eq ""} { + set headerh [expr {max($headerdefminh,$header_maxdataheight)}] + } else { + if {$header_maxdataheight < $headerdefminh} { + set headerh $headerdefminh + } else { + set headerh [expr {max($headerdefminh,$header_maxdataheight)}] + } + } + } + } + + + set headerrow_colspans [tcl::dict::get $all_colspans $hrow] + set this_span [lindex $headerrow_colspans $cidx] + + #set this_hdrwidth [lindex $configured_widths $cidx] + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign + + set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] + set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] + set hval_lines [split $hdr \n] + #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] + tcl::dict::lappend output headers $hcell + } + + + #set colwidth [my column_width $cidx] + #set cell_line_blank [tcl::string::repeat " " $colwidth] + set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1] + set cell_line_blank [tcl::string::repeat " " $datawidth] + + + + set items [tcl::dict::get $o_columndata $cidx] + #puts "---> columndata $o_columndata" + + #set opt_row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] + #set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase + + tcl::dict::set output cells [list];#ensure we return something for cells key if no items in list + set r 0 + foreach cval $items { + #todo move to row_height method ? + set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] + set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] + set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] + if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { + set rowh $rowdefminh ;#an exact height is defined for the row + } else { + if {$rowdefminh eq ""} { + if {$rowdefmaxh eq ""} { + #both defs empty + set rowh $maxdataheight + } else { + set rowh [expr {min(1,$rowdefmaxh,$maxdataheight)}] + } + } else { + if {$rowdefmaxh eq ""} { + set rowh [expr {max($rowdefminh,$maxdataheight)}] + } else { + if {$maxdataheight < $rowdefminh} { + set rowh $rowdefminh + } else { + set rowh [expr {max($rowdefminh,$maxdataheight)}] + } + } + } + } + + set cell_lines [lrepeat $rowh $cell_line_blank] + #set cell_blank [join $cell_lines \n] + + + set cval_lines [split $cval \n] + #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] + + #//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 + + incr r + } + 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 + } + 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\ + ] + foreach {k v} $args { + switch -- $k { + -usetables {} + default { + error "table debug unrecognised option '$k'. Known options: [tcl::dict::keys $defaults]" + } + } + } + set opts [tcl::dict::merge $defaults $args] + set opt_usetables [tcl::dict::get $opts -usetables] + + puts stdout "rowdefs: $o_rowdefs" + puts stdout "rowstates: $o_rowstates" + #puts stdout "columndefs: $o_columndefs" + puts stdout "columndefs:" + if {!$opt_usetables} { + tcl::dict::for {k v} $o_columndefs { + puts " $k $v" + } + } else { + set t [textblock::class::table new] + $t add_column -headers "Col" + tcl::dict::for {col coldef} $o_columndefs { + foreach property [tcl::dict::keys $coldef] { + if {$property eq "-ansireset"} { + continue + } + $t add_column -headers $property + } + break + } + + #build our inner tables first so we can sync widths + set col_header_tables [tcl::dict::create] + set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths + tcl::dict::for {col coldef} $o_columndefs { + set row [list $col] + set colheaders [tcl::dict::get $coldef -headers] + #inner table probably overkill here ..but just as easy + set htable [textblock::class::table new] + $htable configure -show_header 1 -show_edge 0 -show_hseps 0 + $htable add_column -headers row + $htable add_column -headers text + $htable add_column -headers WxH + $htable add_column -headers span + set hnum 0 + set spans [tcl::dict::get $o_columndefs $col -header_colspans] + foreach h $colheaders s $spans { + lassign [textblock::size $h] _w width _h height + $htable add_row [list "$hnum " $h "${width}x${height}" $s] + incr hnum + } + $htable configure_column 0 -ansibase [a+ web-dimgray] + tcl::dict::set col_header_tables $col $htable + set colwidths [$htable column_widths] + set icol 0 + foreach w $colwidths { + if {$w > [tcl::dict::get $max_widths $icol]} { + tcl::dict::set max_widths $icol $w + } + incr icol + } + } + + #safe jumptable test + #dict for {col coldef} $o_columndefs {} + tcl::dict::for {col coldef} $o_columndefs { + set row [list $col] + #safe jumptable test + #dict for {property val} $coldef {} + tcl::dict::for {property val} $coldef { + switch -- $property { + -ansireset {continue} + -headers { + set htable [tcl::dict::get $col_header_tables $col] + tcl::dict::for {innercol maxw} $max_widths { + $htable configure_column $innercol -minwidth $maxw -blockalign left + } + lappend row [$htable print] + $htable destroy + } + default { + lappend row $val + } + } + } + $t add_row $row + } + + + + + $t configure -show_header 1 + puts stdout [$t print] + $t destroy + } + puts stdout "columnstates: $o_columnstates" + puts stdout "headerdefs: $o_headerdefs" + puts stdout "headerstates: $o_headerstates" + tcl::dict::for {k coldef} $o_columndefs { + if {[tcl::dict::exists $o_columndata $k]} { + set headerlist [tcl::dict::get $coldef -headers] + set coldata [tcl::dict::get $o_columndata $k] + set colinfo "rowcount: [llength $coldata]" + set allfields [concat $headerlist $coldata] + if {[llength $allfields]} { + set widest [tcl::mathfunc::max {*}[lmap v $allfields {textblock::width $v}]] + } else { + set widest 0 + } + append colinfo " widest of headers and data: $widest" + } else { + set colinfo "WARNING - no columndata record for column key '$k'" + } + puts stdout "column $k columndata info: $colinfo" + } + set result "" + set cols [list] + set max [expr {[tcl::dict::size $o_columndefs]-1}] + foreach c [tcl::dict::keys $o_columndefs] { + if {$c == 0} { + lappend cols [my get_column_by_index $c -position left] " " + } elseif {$c == $max} { + lappend cols [my get_column_by_index $c -position right] + } else { + lappend cols [my get_column_by_index $c -position inner] " " + } + } + append result [textblock::join -- {*}$cols] + return $result + } + #column width including headers - but without colspan consideration + method column_width_configured {index_expression} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + #assert cidx is now >=0 integer within the range of defined columns + set cdef [tcl::dict::get $o_columndefs $cidx] + set defminw [tcl::dict::get $cdef -minwidth] + set defmaxw [tcl::dict::get $cdef -maxwidth] + if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { + #an exact width is defined for the column - no need to look at data width + set colwidth $defminw + } else { + #set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1] + set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + #set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1] + #set hwidest_singlespan ?? + set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + set widest [expr {max($hwidest,$bwidest)}] + #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. + #if so - a truncated line shouldn't be included in our width calculation + if {$defminw eq ""} { + if {$defmaxw eq ""} { + set colwidth $widest + } else { + set colwidth [expr {min($defmaxw,$widest)}] + } + } else { + if {$defmaxw eq ""} { + set colwidth [expr {max($defminw,$widest)}] + } else { + if {$widest < $defminw} { + set colwidth $defminw + } else { + if {$widest > $defmaxw} { + set colwidth $defmaxw + } else { + set colwidth [expr {max($defminw,$widest)}] + } + } + } + } + } + return $colwidth + } + + 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 + } + return $o_calculated_column_widths + } + + #width of a table includes borders and seps + #whereas width of a column refers to the borderless width (inner width) + method width {} { + #*** !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 + if {[my Showing_vseps]} { + incr twidth [llength $colwidths] + incr twidth -1 + } + if {[tcl::dict::get $o_opts_table -show_edge]} { + incr twidth 2 + } + return $twidth + } + + #column *body* content width + method basic_column_width {index_expression} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + #puts "===column_width $index_expression" + #assert cidx is now >=0 integer within the range of defined columns + set cdef [tcl::dict::get $o_columndefs $cidx] + set defminw [tcl::dict::get $cdef -minwidth] + set defmaxw [tcl::dict::get $cdef -maxwidth] + if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { + #an exact width is defined for the column - no need to look at data width + #review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header + set colwidth $defminw + } else { + #set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0] + set widest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. + #if so - a truncated line shouldn't be included in our width calculation + if {$defminw eq ""} { + if {$defmaxw eq ""} { + set colwidth $widest + } else { + set colwidth [expr {min($defmaxw,$widest)}] + } + } else { + if {$defmaxw eq ""} { + set colwidth [expr {max($defminw,$widest)}] + } else { + if {$widest < $defminw} { + set colwidth $defminw + } else { + if {$widest > $defmaxw} { + set colwidth $defmaxw + } else { + set colwidth [expr {max($defminw,$widest)}] + } + } + } + } + } + set configured_widths [list] + foreach c [tcl::dict::keys $o_columndefs] { + lappend configured_widths [my column_width_configured $c] + } + set header_colspans [my header_colspans] + set width_max $colwidth + set test_width $colwidth + set showing_vseps [my Showing_vseps] + set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + tcl::dict::for {h colspans} $header_colspans { + set spanc [lindex $colspans $cidx] + #set headers [tcl::dict::get $cdef -headers] + #set thiscol_widest_header 0 + #if {[llength $headers] > 0} { + # set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]] + #} + if {$spanc eq "1"} { + if {$thiscol_widest_header > $colwidth} { + set test_width [expr {max($thiscol_widest_header,$colwidth)}] + if {$defmaxw ne ""} { + set test_width [expr {min($colwidth,$defmaxw)}] + } + } + set width_max [expr {max($test_width,$width_max)}] + continue + } + if {$spanc eq "any" || $spanc > 1} { + set spanned [list] ;#spanned is other columns spanned - not including this one + set cnext [expr {$cidx +1}] + set spanlength [lindex $colspans $cnext] + while {$spanlength eq "0" && $cnext < [llength $colspans]} { + lappend spanned $cnext + incr cnext + set spanlength [lindex $colspans $cnext] + } + set others_width 0 + foreach col $spanned { + incr others_width [lindex $configured_widths $col] + if {$showing_vseps} { + incr others_width 1 + } + } + set total_spanned_width [expr {$width_max + $others_width}] + if {$thiscol_widest_header > $total_spanned_width} { + #this just allocates the extra space in the current column - which is not great. + #A proper algorithm for distributing width created by headers to all the spanned columns is needed. + #This is a tricky problem with multiple header lines and arbitrary spans. + #The calculation should probably be done on the table as a whole first and this function should just look up that result. + #Trying to calculate on a specific column only is unlikely to be easy or efficient. + set needed [expr {$thiscol_widest_header - $total_spanned_width}] + #puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)" + if {$defmaxw ne ""} { + set test_width [expr {min($colwidth+$needed,$defmaxw)}] + } else { + set test_width [expr {$colwidth + $needed}] + } + } + } + set width_max [expr {max($test_width,$width_max)}] + } + + #alternative to all the above shennanigans.. let the body cell data determine the size and just wrap the headers + #could also split the needed width amongst the spanned columns? configurable for whether cells expand? + set expand_first_column 1 + if {$expand_first_column} { + set colwidth $width_max + } + + #puts "---column_width $cidx = $colwidth" + return $colwidth + } + method Showing_vseps {} { + #review - show_seps and override mechanism for show_vseps show_hseps - document. + set seps [tcl::dict::get $o_opts_table -show_seps] + set vseps [tcl::dict::get $o_opts_table -show_vseps] + if {$seps eq ""} { + if {$vseps eq "" || $vseps} { + return true + } + } elseif {$seps} { + if {$vseps eq "" || $vseps} { + return true + } + } else { + if {$vseps ne "" && $vseps} { + return true + } + } + return false + } + + method column_datawidth {index_expression args} { + set opts [tcl::dict::create\ + -headers 0\ + -footers 0\ + -colspan unspecified\ + -data 1\ + -cached 1\ + ] + #NOTE: -colspan any is not the same as * + # + #-colspan is relevant to header/footer data only + foreach {k v} $args { + switch -- $k { + -headers - -footers - -colspan - -data - -cached { + tcl::dict::set opts $k $v + } + default { + error "column_datawidth unrecognised flag '$k'. Known flags: [tcl::dict::keys $opts]" + } + } + } + set opt_colspan [tcl::dict::get $opts -colspan] + switch -- $opt_colspan { + * - unspecified {} + any { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0 (use header_colspans_numeric to get actual spans)" + } + default { + if {![string is integer -strict $opt_colspan]} { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0" + } + } + } + + + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + + if {[tcl::dict::get $opts -cached]} { + set hwidest 0 + set bwidest 0 + set fwidest 0 + if {[tcl::dict::get $opts -headers]} { + if {$opt_colspan in {* unspecified}} { + set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + } else { + #this is not cached + # -- --- --- --- + set colheaders [tcl::dict::get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans_numeric] + set hlist [list] + tcl::dict::for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + # -- --- --- --- + } + } + if {[tcl::dict::get $opts -data]} { + set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + } + if {[tcl::dict::get $opts -footers]} { + #TODO! + #set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthfooterseen] + } + return [expr {max($hwidest,$bwidest,$fwidest)}] + } + + #assert cidx is >=0 integer in valid range of keys for o_columndefs + set values [list] + set hwidest 0 + if {[tcl::dict::get $opts -headers]} { + if {$opt_colspan in {* unspecified}} { + lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] + } else { + # -- --- --- --- + set colheaders [tcl::dict::get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans_numeric] + set hlist [list] + tcl::dict::for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + # -- --- --- --- + } + } + if {[tcl::dict::get $opts -data]} { + if {[tcl::dict::exists $o_columndata $cidx]} { + lappend values {*}[tcl::dict::get $o_columndata $cidx] + } + } + if {[tcl::dict::get $opts -footers]} { + lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] + } + if {[llength $values]} { + set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] + set widest [expr {max($valwidest,$hwidest)}] + } else { + set widest $hwidest + } + return $widest + } + #print1 uses basic column joining - useful for testing/debug especially with colspans + method print1 {args} { + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0 } + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set colposn 0 + set numposns [llength $cols] + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + lappend blocks [my get_column_by_index $c {*}$flags] + incr colposn + } + if {[llength $blocks]} { + return [textblock::join -- {*}$blocks] + } else { + return "No columns matched" + } + } + method columncalc_spans {allocmethod} { + set colwidths [tcl::dict::create] ;# to use tcl::dict::incr + set colspace_added [tcl::dict::create] + + set ordered_spans [tcl::dict::create] + tcl::dict::for {col spandata} [my spangroups] { + set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] + set minwidth [tcl::dict::get $o_columndefs $col -minwidth] + set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] + if {$minwidth ne ""} { + if {$dwidth < $minwidth} { + set dwidth $minwidth + } + } + if {$maxwidth ne ""} { + if {$dwidth > $maxwidth} { + set dwidth $maxwidth + } + } + tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered + tcl::dict::set colspace_added $col 0 + + set spanlengths [tcl::dict::get $spandata spanlengths] + foreach slen $spanlengths { + set spans [tcl::dict::get $spandata spangroups $slen] + set spans [lsort -index 7 -integer $spans] + foreach s $spans { + set hwidth [tcl::dict::get $s headerwidth] + set hrow [tcl::dict::get $s hrow] + set scol [tcl::dict::get $s startcol] + tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth + tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth + } + } + } + + #safe jumptable test + #dict for {spanid spandata} $ordered_spans {} + tcl::dict::for {spanid spandata} $ordered_spans { + lassign [split $spanid ,] startcol hrow + set memcols [tcl::dict::get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios + set colids [tcl::dict::keys $memcols] + set hwidth [tcl::dict::get $spandata headerwidth] + set num_cols_spanned [tcl::dict::size $memcols] + if {$num_cols_spanned == 1} { + set col [lindex $memcols 0] + set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] + if {$space_to_alloc > 0} { + set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] + if {$maxwidth ne ""} { + if {$maxwidth > [tcl::dict::get $colwidths $col]} { + set can_alloc [expr {$maxwidth - [tcl::dict::get $colwidths $col]}] + } else { + set can_alloc 0 + } + set will_alloc [expr {min($space_to_alloc,$can_alloc)}] + } else { + set will_alloc $space_to_alloc + } + if {$will_alloc} { + #tcl::dict::set colwidths $col $hwidth + tcl::dict::incr colwidths $col $will_alloc + tcl::dict::set colspace_added $col $will_alloc + } + #log! + #if {$will_alloc < $space_to_alloc} { + # #todo - debug only + # puts stderr "max width $maxwidth hit for col $col - cannot allocate extra [expr {$space_to_alloc - $will_alloc}]" + #} + } + } elseif {$num_cols_spanned > 1} { + set spannedwidth 0 + foreach col $colids { + incr spannedwidth [tcl::dict::get $colwidths $col] + } + set space_to_alloc [expr {$hwidth - $spannedwidth}] + if {[my Showing_vseps]} { + set sepcount [expr {$num_cols_spanned -1}] + incr space_to_alloc -$sepcount + } + #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added + switch -- $allocmethod { + least { + #add to least-expanded each time + #safer than method 1 - pretty balanced + if {$space_to_alloc > 0} { + for {set i 0} {$i < $space_to_alloc} {incr i} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] + foreach testcolid $ordered_all_colids { + if {$testcolid in $colids} { + #assert - we will always find a match + set colid $testcolid + break + } + } + tcl::dict::incr colwidths $colid + tcl::dict::incr colspace_added $colid + } + } + } + least_unmaxed { + #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth + #(we should be able to collapse column width to zero and have header colspans gracefully respond) + #add to least-expanded each time + #safer than method 1 - pretty balanced + if {$space_to_alloc > 0} { + for {set i 0} {$i < $space_to_alloc} {incr i} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] + set colid "" + foreach testcolid $ordered_all_colids { + set maxwidth [tcl::dict::get $o_columndefs $testcolid -maxwidth] + set can_alloc [expr {$maxwidth eq "" || $maxwidth > [tcl::dict::get $colwidths $testcolid]}] + if {$testcolid in $colids} { + if {$can_alloc} { + set colid $testcolid + break + } else { + #remove from future consideration in for loop + #log! + #puts stderr "max width $maxwidth hit for col $testcolid" + tcl::dict::unset colspace_added $testcolid + } + } + } + if {$colid ne ""} { + tcl::dict::incr colwidths $colid + tcl::dict::incr colspace_added $colid + } + } + } + } + all { + #adds space to all columns - not just those spanned - risk of underallocating and truncating some headers! + #probably not a good idea for tables with complex headers and spans + while {$space_to_alloc > 0} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_colids [tcl::dict::keys $ordered_colspace_added] + + foreach col $ordered_colids { + tcl::dict::incr colwidths $col + tcl::dict::incr colspace_added $col + incr space_to_alloc -1 + if {$space_to_alloc == 0} { + break + } + } + } + + } + } + } + } + + set column_widths [tcl::dict::values $colwidths] + #todo - -maxwidth etc + set table_minwidth [tcl::dict::get $o_opts_table -minwidth] ;#min width including frame elements + if {[tcl::string::is integer -strict $table_minwidth]} { + set contentwidth [tcl::mathop::+ {*}$column_widths] + set twidth $contentwidth + if {[my Showing_vseps]} { + incr twidth [llength $column_widths] + incr twidth -1 + } + if {[tcl::dict::get $o_opts_table -show_edge]} { + incr twidth 2 + } + # + set shortfall [expr {$table_minwidth - $twidth}] + if {$shortfall > 0} { + set space_to_alloc $shortfall + while {$space_to_alloc > 0} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_colids [tcl::dict::keys $ordered_colspace_added] + + foreach col $ordered_colids { + tcl::dict::incr colwidths $col + tcl::dict::incr colspace_added $col + incr space_to_alloc -1 + if {$space_to_alloc == 0} { + break + } + } + } + set column_widths [tcl::dict::values $colwidths] + } + + } + + return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] + } + + #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 + foreach c [tcl::dict::keys $o_columndefs] { + tcl::dict::set spangroups $c [list spanlengths {}] + set spanlist [my column_get_spaninfo $c] + set index_spanlen_val 5 + set spanlist [lsort -index $index_spanlen_val -integer $spanlist] + set ungrouped $spanlist + + while {[llength $ungrouped]} { + set spanlen [lindex $ungrouped 0 $index_spanlen_val] + set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen] + set sgroup [list] + foreach p $spangroup_posns { + set spaninfo [lindex $ungrouped $p] + set hcol [tcl::dict::get $spaninfo startcol] + set hrow [tcl::dict::get $spaninfo hrow] + set header [lindex [tcl::dict::get $o_columndefs $hcol -headers] $hrow] + if {[tcl::dict::exists $headerwidths $hcol,$hrow]} { + set hwidth [tcl::dict::get $headerwidths $hcol,$hrow] + } else { + set hwidth [textblock::width $header] + tcl::dict::set headerwidths $hcol,$hrow $hwidth + } + lappend spaninfo headerwidth $hwidth + lappend sgroup $spaninfo + } + set spanlengths [tcl::dict::get $spangroups $c spanlengths] + lappend spanlengths $spanlen + tcl::dict::set spangroups $c spanlengths $spanlengths + tcl::dict::set spangroups $c spangroups $spanlen $sgroup + set ungrouped [lremove $ungrouped {*}$spangroup_posns] + } + } + return $spangroups + } + method column_get_own_spans {cidx} { + set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] + } + method column_get_spaninfo {cidx} { + set spans_by_header [my header_colspans] + set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] + set spaninfo [list] + set numcols [tcl::dict::size $o_columndefs] + #note that 'any' can occur in positions other than column 0 - meaning any remaining until next non-zero span + tcl::dict::for {hrow rawspans} $spans_by_header { + set thiscol_spanval [lindex $rawspans $cidx] + if {$thiscol_spanval eq "any" || $thiscol_spanval > 0} { + set spanstartcol $cidx ;#own column + if {$thiscol_spanval eq "any"} { + #scan right to first non-zero to get actual length of 'any' span + #REVIEW! + set spanlen 1 + for {set i [expr {$cidx+1}]} {$i < $numcols} {incr i} { + #abort at next any or number or empty string + if {[lindex $rawspans $i] ne "0"} { + break + } + incr spanlen + } + #set spanlen [expr {$numcols - $cidx}] + } else { + set spanlen $thiscol_spanval + } + } else { + #look left til we see an any or a non-zero value + for {set i $cidx} {$i > -1} {incr i -1} { + set s [lindex $rawspans $i] + if {$s eq "any" || $s > 0} { + set spanstartcol $i + if {$s eq "any"} { + #REVIEW! + #set spanlen [expr {$numcols - $i}] + set spanlen 1 + #now scan right to see how long the 'any' actually is + for {set j [expr {$i+1}]} {$j < $numcols} {incr j} { + if {[lindex $rawspans $j] ne "0"} { + break + } + incr spanlen + } + } else { + set spanlen $s + } + break + } + } + } + #assert - we should always find 1 answer for each header row + lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen] + } + return $spaninfo + } + method calculate_column_widths {args} { + set column_count [tcl::dict::size $o_columndefs] + + set opts [tcl::dict::create\ + -algorithm $o_column_width_algorithm\ + ] + foreach {k v} $args { + switch -- $k { + -algorithm { + tcl::dict::set opts $k $v + } + default { + error "Unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + set opt_algorithm [tcl::dict::get $opts -algorithm] + #puts stderr "--- recalculating column widths -algorithm $opt_algorithm" + set known_algorithms [list basic simplistic span span2] + switch -- $opt_algorithm { + basic { + #basic column by column - This allocates extra space to first span/column as they're encountered. + #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans + #The header values can extend over some of the spanned columns - but not optimally so. + set o_calculated_column_widths [list] + for {set c 0} {$c < $column_count} {incr c} { + lappend o_calculated_column_widths [my basic_column_width $c] + } + } + simplistic { + #just uses the widest column data or header element. + #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column + #This is a conservative option potentially useful in testing/debugging. + set o_calculated_column_widths [list] + for {set c 0} {$c < $column_count} {incr c} { + lappend o_calculated_column_widths [my column_width_configured $c] + } + } + span { + #widest of smallest spans first method + #set calcresult [my columncalc_spans least] + set calcresult [my columncalc_spans least_unmaxed] + set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] + } + span2 { + #allocates more evenly - but truncates headers sometimes + set calcresult [my columncalc_spans all] + set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] + } + default { + error "calculate_column_widths unknown algorithm $opt_algorithm. Known algorithms: $known_algorithms" + } + } + #remember the last algorithm used + set o_column_width_algorithm $opt_algorithm + return $o_calculated_column_widths + } + method print2 {args} { + variable full_column_cache + set full_column_cache [tcl::dict::create] + + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set colposn 0 + set numposns [llength $cols] + set padwidth 0 + set table "" + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + #lappend blocks [my get_column_by_index $c {*}$flags] + #todo - only check and store in cache if table has header or footer colspans > 1 + if {[tcl::dict::exists $full_column_cache $c]} { + #puts "!!print used full_column_cache for $c" + set columninfo [tcl::dict::get $full_column_cache $c] + } else { + set columninfo [my get_column_by_index $c -return dict {*}$flags] + tcl::dict::set full_column_cache $c $columninfo + } + set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] + set bodywidth [tcl::dict::get $columninfo bodywidth] + + if {$table eq ""} { + set table $nextcol + set height [textblock::height $table] ;#only need to get height once at start + } else { + set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] + set table [overtype::renderspace -expand_right 1 -transparent $TSUB $table[unset table] $nextcol] + #JMN + + #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] + #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] + } + incr padwidth $bodywidth + incr colposn + } + + if {[llength $cols]} { + #return [textblock::join -- {*}$blocks] + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + + # using -startcolumn to do slightly less work + method print3 {args} { + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set numposns [llength $cols] + set colposn 0 + set padwidth 0 + set table "" + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + set columninfo [my get_column_by_index $c -return dict {*}$flags] + set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] + set bodywidth [tcl::dict::get $columninfo bodywidth] + + if {$table eq ""} { + set table $nextcol + set height [textblock::height $table] ;#only need to get height once at start + } else { + set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] + } + incr padwidth $bodywidth + incr colposn + } + + if {[llength $cols]} { + #return [textblock::join -- {*}$blocks] + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + + #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 { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set numposns [llength $cols] + set colposn 0 + set padwidth 0 + set header_build "" + set body_blocks [list] + set headerheight 0 + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + set columninfo [my get_column_by_index $c -return dict {*}$flags] + #set nextcol [tcl::dict::get $columninfo column] + set bodywidth [tcl::dict::get $columninfo bodywidth] + set headerheight [tcl::dict::get $columninfo headerheight] + #set nextcol_lines [split $nextcol \n] + #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] + #set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n] + set nextcol_header [tcl::dict::get $columninfo header] + set nextcol_body [tcl::dict::get $columninfo body] + + if {$header_build eq "" && ![llength $body_blocks]} { + set header_build $nextcol_header + } else { + if {$headerheight > 0} { + set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] + } + #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] + } + lappend body_blocks $nextcol_body + incr padwidth $bodywidth + incr colposn + } + if {![llength $body_blocks]} { + set body_build "" + } else { + #body blocks should not be ragged - so can use join_basic + set body_build [textblock::join_basic -- {*}$body_blocks] + } + if {$headerheight > 0} { + set table [tcl::string::cat $header_build \n $body_build] + } else { + set table $body_build + } + + if {[llength $cols]} { + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + 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 + } + + #*** !doctools + #[list_end] + }] + #*** !doctools + # [list_end] [comment {- end enumeration provider_classes }] + #[list_end] [comment {- end itemized list textblock::class groupings -}] + } + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# +#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 *} + tcl::namespace::import ::term::ansi::code::macros::cd::* + tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} + } + proc spantest {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2] + $t configure_column 0 -header_colspans {3 4 5 any 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + proc spantest1 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers [list "span3-any longer than other span any" "1-span4\n2-span4 second line" "span-any short aligned?" "span5/5 longest etc blah 123" span2] + $t configure_column 0 -header_colspans {any 4 any 5 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 0 0 0} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + $t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs) + return $t + } + + #more complex colspans + proc spantest2 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} + $t configure_column 0 -header_colspans {3 4 1 any 2} + $t configure_column 1 -header_colspans {0 0 2 0 0} + $t configure_column 2 -headers {"" "" "" "" c2span2} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 2 0 0} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + proc spantest3 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1} + $t configure_column 0 -header_colspans {3 4 1 any 2 1} + $t configure_column 1 -header_colspans {0 0 4 0 0 1} + $t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"} + $t configure_column 2 -headers {"" "" "" "" "" c2span2} + $t configure_column 2 -header_colspans {0 0 0 0 1 2} + $t configure_column 4 -headers {"4" "444" "" "" "" "44"} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + + punk::args::define { + @id -id ::textblock::periodic + @cmd -name textblock::periodic -help "A rudimentary periodic table + This is primarily a test of textblock::class::table" + + -return -default table\ + -choices {table tableobject}\ + -help "default choice 'table' returns the displayable table output" + -compact -default 1 -type boolean -help "compact true defaults: -show_vseps 0 -show_header 0 -show_edge 0" + -frame -default 1 -type boolean + -show_vseps -default "" -type boolean + -show_header -default "" -type boolean + -show_edge -default "" -type boolean + -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" + @values -min 0 -max 0 + } + + proc periodic {args} { + #For an impressive interactive terminal app (javascript) + # see: https://github.com/spirometaxas/periodic-table-cli + set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + set opt_return [tcl::dict::get $opts -return] + if {[tcl::dict::get $opts -forcecolour]} { + set fc forcecolour + } else { + set fc "" + } + + #examples ptable.com + set elements [list\ + 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ + 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ + 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ + 4 K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr\ + 5 Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe\ + 6 Cs Ba "" Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn\ + 7 Fr Ra "" Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og\ + " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ + "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ + "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ + ] + + set type_colours [list] + + set ecat [tcl::dict::create] + + set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] + set ansi [a+ {*}$fc web-black Web-gold] + set val [list ansi $ansi cat alkaline_earth] + foreach e $cat_alkaline_earth { + tcl::dict::set ecat $e $val + } + + set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] + #set ansi [a+ {*}$fc web-black Web-lightgreen] + set ansi [a+ {*}$fc black Term-113] + set val [list ansi $ansi cat reactive_nonmetal] + foreach e $cat_reactive_nonmetal { + tcl::dict::set ecat $e $val + } + + set cat [list Li Na K Rb Cs Fr] + #set ansi [a+ {*}$fc web-black Web-Khaki] + set ansi [a+ {*}$fc black Term-lightgoldenrod2] + set val [list ansi $ansi cat alkali_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] + #set ansi [a+ {*}$fc web-black Web-lightsalmon] + set ansi [a+ {*}$fc black Term-orange1] + set val [list ansi $ansi cat transition_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Al Ga In Sn Tl Pb Bi Po] + set ansi [a+ {*}$fc web-black Web-lightskyblue] + set val [list ansi $ansi cat post_transition_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list B Si Ge As Sb Te At] + #set ansi [a+ {*}$fc web-black Web-turquoise] + set ansi [a+ {*}$fc black Brightcyan] + set val [list ansi $ansi cat metalloids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list He Ne Ar Kr Xe Rn] + set ansi [a+ {*}$fc web-black Web-orchid] + set val [list ansi $ansi cat noble_gases] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] + set ansi [a+ {*}$fc web-black Web-plum] + set val [list ansi $ansi cat actinoids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] + #set ansi [a+ {*}$fc web-black Web-tan] + set ansi [a+ {*}$fc black Term-tan] + set val [list ansi $ansi cat lanthanoids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set ansi [a+ {*}$fc web-black Web-whitesmoke] + set val [list ansi $ansi cat other] + foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { + tcl::dict::set ecat $e $val + } + + set elements1 [list] + set RST [a+] + foreach e $elements { + if {[tcl::dict::exists $ecat $e]} { + set ansi [tcl::dict::get $ecat $e ansi] + #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] + #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway + lappend elements1 $ansi$e + } else { + lappend elements1 $e + } + } + + set t [list_as_table -columns 19 -return tableobject $elements1] + #(defaults to show_hseps 0) + + #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options + + set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] + set c 0 + foreach h $header_0 { + $t configure_column $c -headers [list $h] -minwidth 2 + incr c + } + set ccount [$t column_count] + for {set c 0} {$c < $ccount} {incr c} { + $t configure_column $c -minwidth 3 + } + if {[tcl::dict::get $opts -compact]} { + #compact defaults - but let explicit arguments override + set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0] + } else { + set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1] + } + dict for {k v} $conf { + if {[dict get $opts $k] ne ""} { + dict set conf $k [dict get $opts $k] + } + } + + set moreopts [dict create\ + -frametype_header light\ + -ansiborder_header [a+ {*}$fc brightwhite]\ + -ansibase_header [a+ {*}$fc Black]\ + -ansibase_body [a+ {*}$fc Black]\ + -ansiborder_body [a+ {*}$fc black]\ + -frametype block + ] + $t configure {*}[dict merge $conf $moreopts] + + #-ansiborder_header [a+ {*}$fc web-white]\ + + if {$opt_return eq "table"} { + 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 -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + } else { + set output [$t print] + } + $t destroy + return $output + } + return $t + } + + proc bookend_lines {block start {end "\x1b\[m"}} { + set out "" + foreach ln [split $block \n] { + append out $start $ln $end \n + } + return [string range $out 0 end-1] + } + proc ansibase_lines {block {newprefix ""}} { + set base "" + set out "" + if {$newprefix eq ""} { + if {![punk::ansi::ta::detect $block]} { + return $block + } + foreach ln [split $block \n] { + set parts [punk::ansi::ta::split_codes $ln] + if {[lindex $parts 0] eq ""} { + if {[lindex $parts 1] ne "" && ![punk::ansi::codetype::is_sgr_reset [lindex $parts 1]]} { + set base [lindex $parts 1] + append out $base + } else { + append out $base + } + } else { + #leading plaintext - maintain our base + append out $base [lindex $parts 0] [lindex $parts 1] + } + + set code_idx 3 + foreach {pt code} [lrange $parts 2 end] { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set parts [linsert $parts $code_idx+1 $base] + } + incr code_idx 2 + } + append out {*}[lrange $parts 2 end] \n + } + return [string range $out 0 end-1] + } else { + set base $newprefix + if {![punk::ansi::ta::detect $block]} { + foreach ln [split $block \n] { + append out $base $ln \n + } + return $out + } + foreach ln [split $block \n] { + set parts [punk::ansi::ta::split_codes $ln] + set code_idx 1 + set offset 0 + foreach {pt code} $parts { + if {$code_idx == 1} { + #first pt & code + if {$pt ne ""} { + #leading plaintext + set parts [linsert $parts 0 $base] + incr offset + } + } + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set parts [linsert $parts [expr {$code_idx+1+$offset}] $base] + incr offset + } + incr code_idx 2 + } + append out {*}$parts \n + } + return [string range $out 0 end-1] + } + } + + set FRAMETYPES [textblock::frametypes] + punk::args::define [punk::lib::tstr -return string { + @id -id ::textblock::list_as_table + @cmd -name "textblock::list_as_table" -help\ + "Display a list in a bordered 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 "Each supplied -header argument is a header row. + The number of values for each must be <= number of columns" + -show_header -type boolean\ + -help "Whether to show a header row. + Omit 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 + Will default to 2 if not using an existing -table object" + + @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_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 count [llength $datalist] + + set is_new_table 0 + if {$existing_table ne ""} { + if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} { + error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])" + } + set t $existing_table + foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} { + if {[tcl::dict::get $opts $prop] ne ""} { + $t configure $prop [tcl::dict::get $opts $prop] + } + } + if {[dict get $opts -action] eq "replace"} { + $t row_clear + } + set cols [$t column_count] + if {[tcl::string::is integer -strict $opt_columns]} { + if {$opt_columns > $cols} { + set extra [expr {$opt_columns - $cols}] + for {set c 0} {$c < $extra} {incr c} { + $t add_column + } + } elseif {$opt_columns < $cols} { + #todo - auto add blank values in the datalist + error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported" + } + set cols [$t column_count] + } + } else { + set is_new_table 1 + set colheaders {} + if {[tcl::dict::get $opts -colheaders] ne ""} { + set colheaders [dict get $opts -colheaders] + } else { + set colheaders [list] + } + set r 0 + foreach ch $colheaders { + set rows [llength $ch] + if {$r < $rows} { + set r $rows + } + } + if {[llength [tcl::dict::get $opts -header]]} { + foreach hrow [tcl::dict::get $opts -header] { + set c 0 + foreach cell $hrow { + if {[llength $colheaders] < $c+1} { + lappend colheaders [lrepeat $r {}] + } + set colinfo [lindex $colheaders $c] + if {$r > [llength $colinfo]} { + set diff [expr {$r - [llength $colinfo]}] + lappend colinfo {*}[lrepeat $diff {}] + } + lappend colinfo $cell + lset colheaders $c $colinfo + incr c + } + incr r + } + } + + + if {[llength $colheaders] > 0} { + if {![tcl::dict::exists $opts received -show_header]} { + set show_header 1 + } else { + set show_header [tcl::dict::get $opts -show_header] + } + } else { + if {![tcl::dict::exists $opts received -show_header]} { + set show_header 0 + } else { + set show_header [tcl::dict::get $opts -show_header] + } + } + + if {[tcl::string::is integer -strict $opt_columns]} { + set cols $opt_columns + if {[llength $colheaders] && $cols != [llength $colheaders]} { + error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $colheaders])" + } + } else { + #review + if {[llength $colheaders]} { + set cols [llength $colheaders] + } else { + set cols 2 ;#seems a reasonable default + } + } + #defaults for new table only + #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_vseps] eq ""} { + tcl::dict::set opts -show_vseps 1 + } + if {[tcl::dict::get $opts -show_hseps] eq ""} { + tcl::dict::set opts -show_hseps 0 + } + + set t [textblock::class::table new\ + -show_header $show_header\ + -show_edge [tcl::dict::get $opts -show_edge]\ + -frametype [tcl::dict::get $opts -frametype]\ + -show_seps [tcl::dict::get $opts -show_seps]\ + -show_vseps [tcl::dict::get $opts -show_vseps]\ + -show_hseps [tcl::dict::get $opts -show_hseps]\ + ] + if {[llength $colheaders]} { + for {set c 0} {$c < $cols} {incr c} { + $t add_column -headers [lindex $colheaders $c] + } + } else { + for {set c 0} {$c < $cols} {incr c} { + $t add_column -headers [list $c] + } + } + } + + set full_rows [expr {$count / $cols}] + set last_items [expr {$count % $cols}] + + + set rowdata [list] + set row [list] + set i 0 + if {$full_rows > 0} { + for {set r 0} {$r < $full_rows} {incr r} { + set j [expr {$i + ($cols -1)}] + set row [lrange $datalist $i $j] + incr i $cols + lappend rowdata $row + } + } + if {$last_items > 0} { + set idx [expr {$last_items -1}] + lappend rowdata [lrange $datalist end-$idx end] + } + foreach row $rowdata { + set shortfall [expr {$cols - [llength $row]}] + if {$shortfall > 0} { + #set row [concat $row [lrepeat $shortfall ""]] + lappend row {*}[lrepeat $shortfall ""] + } + $t add_row $row + } + #puts stdout $rowdata + if {[tcl::dict::get $opts -return] eq "table"} { + set result [$t print] + if {$is_new_table} { + $t destroy + } + return $result + } else { + return $t + } + } + #return a homogenous block of characters - ie lines all same length, all same character + #printing-width in terminal columns is not necessarily same as blockwidth even if a single char is passed (could be full-width unicode character) + #This can have ansi SGR codes - but to repeat blocks containing ansi-movements, the block should first be rendered to a static output with something like overtype::left + proc block {blockwidth blockheight {char " "}} { + if {$blockwidth < 0} { + error "textblock::block blockwidth must be an integer greater than or equal to zero" + } + if {$blockheight <= 0} { + error "textblock::block blockheight must be a positive integer" + } + if {$char eq ""} {return ""} + #using tcl::string::length is ok + if {[tcl::string::length $char] == 1} { + set row [tcl::string::repeat $char $blockwidth] + set mtrx [lrepeat $blockheight $row] + return [::join $mtrx \n] + } else { + set charblock [tcl::string::map [list \r\n \n] $char] + if {[tcl::string::last \n $charblock] >= 0} { + if {$blockwidth > 1} { + #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) + set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] + } else { + set row $charblock + } + } else { + set row [tcl::string::repeat $char $blockwidth] + } + set mtrx [lrepeat $blockheight $row] + return [::join $mtrx \n] + } + } + + + punk::args::define { + @id -id ::textblock::testblock + @cmd -name textblock::testblock -help\ + "Create a block of characters size + columns wide and size rows tall. + (which on a terminal will show as a + vertically oriented rectangle due to + cells being taller than their width) + + The characters used are + 123456789ABCDEF + " + -size -type integer\ + -default 15\ + -optional 1\ + -range {1 15} + -direction -default horizontal\ + -choices {horizontal vertical}\ + -help\ + "When rainbow is in the colour list, + this also affects the direction of + colour changes" + @values -min 0 -max 2 + colour -type list -default {} -optional 1 -help\ + "List of Ansi colour names + e.g. testblock 10 {white Red} + produces a block of character 10x10 + with white text on red bacground + + The additional pseudo-color 'rainbow' + is available. + " + } + + proc testblock {args} { + set argd [punk::args::get_by_id ::textblock::testblock $args] + set colour [dict get $argd values colour] + set size [dict get $argd opts -size] + + set rainbow_list [list] + lappend rainbow_list {30 47} ;#black White + lappend rainbow_list {31 46} ;#red Cyan + lappend rainbow_list {32 45} ;#green Purple + lappend rainbow_list {33 44} ;#yellow Blue + lappend rainbow_list {34 43} ;#blue Yellow + lappend rainbow_list {35 42} ;#purple Green + lappend rainbow_list {36 41} ;#cyan Red + lappend rainbow_list {37 40} ;#white Black + lappend rainbow_list {black Yellow} + lappend rainbow_list red + lappend rainbow_list green + lappend rainbow_list yellow + lappend rainbow_list blue + lappend rainbow_list purple + lappend rainbow_list cyan + lappend rainbow_list {white Red} + + #set rainbow_direction "horizontal" + #set vpos [lsearch $colour vertical] + #if {$vpos >= 0} { + # set rainbow_direction vertical + # set colour [lremove $colour $vpos] + #} + #set hpos [lsearch $colour horizontal] + #if {$hpos >=0} { + # #horizontal is the default and superfluous but allowed for symmetry + # set colour [lremove $colour $hpos] + #} + set direction [dict get $argd opts -direction] + + + + 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 "" + } else { + set RST [a] + } + if {"rainbow" in $colour && $direction eq "vertical"} { + #column first - colour change each column + set c [::join $charsubset \n] + + set clist [list] + for {set i 0} {$i <$size} {incr i} { + set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] + set ansi [a+ {*}$colour2] + + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] + lappend clist ${ansicode}$c$RST + } + if {"noreset" in $colour} { + return [textblock::join_basic -ansiresets 0 -- {*}$clist] + } else { + return [textblock::join_basic -- {*}$clist] + } + } elseif {"rainbow" in $colour} { + #direction must be horizontal + set block "" + for {set r 0} {$r < $size} {incr r} { + set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] + set ansi [a+ {*}$colour2] + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] + set row "$ansicode" + foreach c $charsubset { + append row $c + } + append row $RST + append block $row\n + } + set block [tcl::string::trimright $block \n] + return $block + } else { + #row first - + set rows [list] + foreach ch $charsubset { + lappend rows [tcl::string::repeat $ch $size] + } + set block [::join $rows \n] + if {$colour ne ""} { + set block [a+ {*}$colour]$block$RST + } + return $block + } + } + interp alias {} testblock {} textblock::testblock + + #todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table + proc width {textblock} { + #backspaces, vertical tabs ? + if {$textblock eq ""} { + return 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 {[string length $textblock] > 1 && [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}]] + } + 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 {[string length $textblock] > 1 && [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] + if {$firstnl >= 0} { + set tl [tcl::string::range $textblock 0 $firstnl] + } else { + set tl $textblock + } + if {[punk::ansi::ta::detect $tl]} { + set tl [punk::ansi::ansistripraw $tl] + } + return [punk::char::ansifreestring_width $tl] + } + #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. + proc string_length_line_max {textblock} { + #tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + set max 0 + foreach ln [split $textblock \n] { + if {[tcl::string::length $ln] > $max} {set max [tcl::string::length $ln]} + } + return $max + } + #*slightly* slower + #proc string_length_line_max {textblock} { + # tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + #} + proc string_length_line_min textblock { + tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + } + + proc height {textblock} { + #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le + #empty string still has height 1 (at least for left-right/right-left languages) + + #vertical tab on a proper terminal should move directly down. + #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) + + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + } + #MAINTENANCE - same as overtype::blocksize? + proc size {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack + 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] + } + #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests + if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] + set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + } else { + set width [punk::char::ansifreestring_width $textblock] + } + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height + } + proc size2 {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack + 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] + } + #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests + if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] + set lines [split $textblock \n] + set num_le [expr {[llength $lines]-1}] + #set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]] + set width 0 + foreach ln $lines { + set w [::punk::char::ansifreestring_width $ln] + if {$w > $width} { + set width $w + } + } + } else { + set num_le 0 + set width [punk::char::ansifreestring_width $textblock] + } + #set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height + } + proc size_as_opts {textblock} { + set sz [size $textblock] + return [dict create -width [dict get $sz width] -height [dict get $sz height]] + } + proc size_as_list {textblock} { + set sz [size $textblock] + return [list [dict get $sz width] [dict get $sz height]] + } + #must be able to handle block as string with or without newlines + #if no newlines - attempt to treat as a list + #must handle whitespace-only string,list elements, and/or lines. + #reviewing 2024 - this seems like too much magic! + proc width1 {block} { + if {$block eq ""} { + return 0 + } + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set block [textutil::tabify::untabify2 $block $tw] + if {[tcl::string::last \n $block] >= 0} { + return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]] + } + if {[catch {llength $block}]} { + return [::punk::char::string_width [ansistrip $block]] + } + if {[llength $block] == 0} { + #could be just a whitespace string + return [tcl::string::length $block] + } + return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]] + } + + #we shouldn't make textblock depend on the punk pipeline system + #pipealias ::textblock::padleft .= {list $input [tcl::string::repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" + foreach {k v} $args { + switch -- $k { + -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { + tcl::dict::set opts $k $v + } + default { + error "textblock::pad unrecognised option '$k'. Usage: $usage" + } + } + } + # -- --- --- --- --- --- --- --- --- --- + set padchar [tcl::dict::get $opts -padchar] + #if padchar width (screen width) > 1 - length calculations will not be correct + #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map + #The caller may also use ansi within the padchar - although it's unlikely to be efficient. + # -- --- --- --- --- --- --- --- --- --- + set known_whiches [list l left r right c center centre] + set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] + switch -- $opt_which { + center - centre - c { + set which c + } + left - l { + set which l + } + right - r { + set which r + } + default { + error "textblock::pad unrecognised value for -which option. Known values $known_whiches" + } + } + # -- --- --- --- --- --- --- --- --- --- + set opt_width [tcl::dict::get $opts -width] + switch -- $opt_width { + "" - auto { + set width auto + } + default { + if {![tcl::string::is integer -strict $opt_width] || $opt_width < 0} { + error "textblock::pad -width must be an integer >=0" + } + set width $opt_width + } + } + # -- --- --- --- --- --- --- --- --- --- + set opt_withinansi [tcl::dict::get $opts -within_ansi] + switch -- $opt_withinansi { + 0 - 1 {} + default { + set opt_withinansi 2 + } + } + # -- --- --- --- --- --- --- --- --- --- + 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"} { + #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] + + set padcharsize [punk::ansi::printing_length $padchar] + set pad_has_ansi [punk::ansi::ta::detect $padchar] + if {$block eq ""} { + #we need to treat as a line + set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + #TODO + #review - what happens when padchar has ansi, or the width would split a double-wide unicode char? + #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) + #we should use overtype with suitable replacement char (space?) for chopped double-wides + if {!$pad_has_ansi} { + return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] + } else { + set base [tcl::string::repeat " " $width] + return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + } + + #review - tcl format can only pad with zeros or spaces? + #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 + #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 + + 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 + foreach {pt ansi} $parts { + if {$pt ne ""} { + set has_nl [expr {[tcl::string::last \n $pt]>=0}] + if {$has_nl} { + set pt [tcl::string::map [list \r\n \n] $pt] + set partlines [split $pt \n] + } else { + set partlines [list $pt] + } + set last [expr {[llength $partlines]-1}] + set p 0 + foreach pl $partlines { + lappend line_chunks $pl + #incr line_len [punk::char::ansifreestring_width $pl] + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + } + if {$p != $last} { + #do padding + 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 + + #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars + if {[tcl::dict::exists $pad_cache $missing]} { + set pad [tcl::dict::get $pad_cache $missing] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + dict set pad_cache $missing $pad + } + switch -- $which-$opt_withinansi { + r-0 { + lappend line_chunks $pad + } + r-1 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + } + r-2 { + lappend line_chunks $pad + } + l-0 { + set line_chunks [linsert $line_chunks 0 $pad] + } + l-1 { + if {[lindex $line_chunks 0] eq ""} { + set line_chunks [linsert $line_chunks 2 $pad] + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + l-2 { + if {$lnum == 0} { + if {[lindex $line_chunks 0] eq ""} { + set line_chunks [linsert $line_chunks 2 $pad] + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + } + } + lappend lines [::join $line_chunks ""] + set line_chunks [list] + set line_len 0 + incr lnum + } + incr p + } + } else { + #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes + lappend line_chunks "" + } + #don't let trailing empty ansi affect the line_chunks length + if {$ansi ne ""} { + lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? + } + } + #pad last line + 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] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + } + #set pad [tcl::string::repeat $padchar $missing] + switch -- $which-$opt_withinansi { + r-0 { + lappend line_chunks $pad + } + r-1 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + } + r-2 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + #lappend line_chunks $pad + } + l-0 { + #if {[lindex $line_chunks 0] eq ""} { + # set line_chunks [linsert $line_chunks 2 $pad] + #} else { + # set line_chunks [linsert $line_chunks 0 $pad] + #} + set line_chunks [linsert $line_chunks 0 $pad] + } + l-1 { + #set line_chunks [linsert $line_chunks 0 $pad] + set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] + } + l-2 { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + } + lappend lines [::join $line_chunks ""] + return [::join $lines \n] + } + + #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single + #resulting list is no longer a valid ansisplit list + proc _insert_before_text_or_last_ansi {str ansisplits} { + if {[llength $ansisplits] == 1} { + #ansisplits was a split on plaintext only + return [list $str [lindex $ansisplits 0]] + } elseif {[llength $ansisplits] == 0} { + return [list $str] + } + if {[llength $ansisplits] %2 != 1} { + error "_insert_before_text_or_last_ansi ansisplits list is not a valid resultlist from an ansi split - must be odd number of elements pt,ansi,pt,ansi...pt" + } + set out [list] + set i 0 + set i_last_code [expr {[llength $ansisplits]-3}] ;#would normally be -2 - but our i is jumping to each pt - not every element + foreach {pt code} $ansisplits { + if {$pt ne ""} { + return [lappend out $str {*}[lrange $ansisplits $i end]] + } + if {$i == $i_last_code} { + return [lappend out $str {*}[lrange $ansisplits $i end]] + } + #code being empty can only occur when we have reached last pt + #we have returned by then. + lappend out $code + incr i 2 + } + error "_insert_before_text_or_last_ansi failed on input str:[ansistring VIEW $str] ansisplits:[ansistring VIEW $ansisplits]" + } + proc pad_test {block} { + set width [textblock::width $block] + set padtowidth [expr {$width + 10}] + 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] + + set t [textblock::list_as_table -columns 3 -return tableobject $testlist] + $t configure_column 0 -headers [list "ansi"] + $t configure_column 1 -headers [list "Left"] + $t configure_column 2 -headers [list "Right"] + $t configure -show_header 1 + puts stdout [$t print] + return $t + } + + proc pad_test_blocklist {blocklist args} { + set opts [tcl::dict::create\ + -description ""\ + -blockheaders ""\ + ] + foreach {k v} $args { + switch -- $k { + -description - -blockheaders { + tcl::dict::set opts $k $v + } + default { + error "pad_test_blocklist unrecognised option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + set opt_blockheaders [tcl::dict::get $opts -blockheaders] + set bheaders [tcl::dict::create] + if {$opt_blockheaders ne ""} { + set b 0 + foreach h $opt_blockheaders { + if {$b < [llength $blocklist]} { + tcl::dict::set bheaders $b $h + } + incr b + } + } + + set b 0 + set blockinfo [tcl::dict::create] + foreach block $blocklist { + set width [textblock::width $block] + tcl::dict::set blockinfo $b width $width + set padtowidth [expr {$width + 3}] + tcl::dict::set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] + tcl::dict::set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] + tcl::dict::set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] + tcl::dict::set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] + tcl::dict::set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] + tcl::dict::set blockinfo $b right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] + incr b + } + + set r0 [list "0"] + set r1 [list "1"] + set r2 [list "2"] + set r3 [list "column\ncolours"] + + #1 + #test without table padding + #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering + #(basically a mechanism to add extra resets at start and end of each line) + #dict for {b bdict} $blockinfo { + # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] + # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] + # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] + #} + + #2 - the more useful one? + tcl::dict::for {b bdict} $blockinfo { + lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] + lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] + lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] + lappend r3 "" "" + } + + set rows [concat $r0 $r1 $r2 $r3] + + set column_ansi [a+ web-white Web-Gray] + + set t [textblock::list_as_table -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows] + $t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi + set col 1 + tcl::dict::for {b bdict} $blockinfo { + if {[tcl::dict::exists $bheaders $b]} { + set hdr [tcl::dict::get $bheaders $b] + } else { + set hdr "Block $b" + } + $t configure_column $col -headers [list $hdr "Left"] -minwidth [expr {$padtowidth + 2}] + $t configure_column $col -header_colspans 2 -ansibase $column_ansi + incr col + $t configure_column $col -headers [list "-" "Right"] -minwidth [expr {$padtowidth + 2}] -ansibase $column_ansi + incr col + } + $t configure -show_header 1 + puts stdout [$t print] + return $t + } + proc pad_example {} { + set headers [list] + set blocks [list] + + lappend blocks "[textblock::testblock 4 rainbow]" + lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" + + lappend blocks "[textblock::testblock 4 rainbow][a]" + lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" + + lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" + lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}]" + lappend headers "rainbow 4x4\nno line resets\nnothing trailing" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" + lappend headers "rainbow 4x4\nno line resets\ntrailing reset" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" + lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" + + set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] + } + proc pad_example2 {} { + set headers [list] + set blocks [list] + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" + + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" + + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" + + set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] + } + + + #playing with syntax + + # pipealias ::textblock::join_width .= {list $lhs [tcl::string::repeat " " $w1] $rhs [tcl::string::repeat " " $w2]} {| + # /2,col1/1,col2/3 + # >} punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| + # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| + # >} punk::lib::list_as_lines -- $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} { + #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. + # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner + #" + 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 + } + set idx 0 + set fordata [list] + set colindices [list] + foreach b $blocks { + if {[punk::ansi::ta::detect $b]} { + lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] + } else { + lappend fordata "v($idx)" [split $b \n] + } + lappend colindices $idx + incr idx + } + set outlines [list] + foreach {*}$fordata { + set row {} + foreach colidx $colindices { + lappend row $v($colidx) + } + lappend outlines [::join $row ""] + } + return [::join $outlines \n] + } + #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed + #they may however still be 'ragged' ie differing line lengths + proc ::textblock::join {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 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] + 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] + } 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 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 " "] + } + lappend outlines $row + } + #puts stderr "--->outlines len: [llength $outlines]" + return [::join $outlines \n] + } + + proc ::textblock::trim {block} { + error "textblock::trim unimplemented" + set trimlines "" + } + + #pipealias ::textblock::join_right .= {list $lhs [tcl::string::repeat " " [width $lhs]] $rhs [tcl::string::repeat " " [width $rhs]]} {| + # /2,col1/1,col2/3 + # >} .=> punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| + # >} punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] + set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] + set testblock [textblock::testblock 15 rainbow] + set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] + set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] + } + + + proc example {args} { + set opts [tcl::dict::create -forcecolour 0] + foreach {k v} $args { + switch -- $k { + -forcecolour { + tcl::dict::set opts $k $v + } + default { + error "textblock::example unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]" + } + } + } + set opt_forcecolour 0 + if {[tcl::dict::get $opts -forcecolour]} { + set fc forcecolour + set opt_forcecolour 1 + } else { + set fc "" + } + set pleft [>punk . rhs] + set pright [>punk . lhs] + set prightair [>punk . lhs_air] + set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] + set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] + set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] + set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] + set RST [a] + set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] + set punks [textblock::join -- $pleft $pright] + set pleft_greenb $greenb$pleft$RST + set pright_redb $redb$pright$RST + set prightair_cyanb $cyanb$prightair$RST + set cpunks [textblock::join -- $pleft_greenb $pright_redb] + set out "" + append out $punks \n + append out $cpunks \n + append out [textblock::join -- $punks $cpunks] \n + 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 -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 -- $punkdeck " " $spantable] \n + #append out [textblock::frame -title gr $gr0] + append out [textblock::periodic -forcecolour $opt_forcecolour] + return $out + } + + proc example3 {{text "test\netc\nmore text"}} { + package require patternpunk + .= textblock::join -- [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join -- " " |> .=>1 textblock::join -- $text |> .=>1 textblock::join -- [>punk . rhs] |> .=>1 textblock::join -- [punk::lib::list_as_lines -- [lrepeat 7 " | "]] + } + proc example2 {{text "test\netc\nmore text"}} { + package require patternpunk + .= textblock::join\ + --\ + [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7 8]]\ + [>punk . lhs]\ + " "\ + $text\ + [>punk . rhs]\ + [punk::lib::list_as_lines -- [lrepeat 8 " | "]] + } + proc table {args} { + #todo - use punk::args + upvar ::textblock::class::opts_table_defaults toptdefaults + set defaults [tcl::dict::create\ + -rows [list]\ + -headers [list]\ + -return string\ + ] + + + set defaults [tcl::dict::merge $defaults $toptdefaults] ;# -title -frametype -show_header etc + set opts [tcl::dict::merge $defaults $args] + # -- --- --- --- + set opt_return [tcl::dict::get $opts -return] + set opt_rows [tcl::dict::get $opts -rows] + set opt_headers [tcl::dict::get $opts -headers] + # -- --- --- --- + set topts [tcl::dict::create] + set toptkeys [tcl::dict::keys $toptdefaults] + tcl::dict::for {k v} $opts { + if {$k in $toptkeys} { + tcl::dict::set topts $k $v + } + } + set t [textblock::class::table new {*}$topts] + + foreach h $opt_headers { + $t add_column -headers [list $h] + } + if {[$t column_count] == 0} { + if {[llength $opt_rows]} { + set r0 [lindex $opt_rows 0] + foreach c $r0 { + $t add_column + } + } + } + foreach r $opt_rows { + $t add_row $r + } + + + + if {$opt_return eq "string"} { + set result [$t print] + $t destroy + return $result + } else { + return $t + } + } + + proc frametype {f} { + #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] + switch -- $f { + 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 { + set is_custom_dict_ok 1 + if {[llength $f] %2 == 0} { + #custom dict may leave out keys - but cannot have unknown keys + foreach {k v} $f { + switch -- $k { + all - 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 + break + } + } + } + } else { + set is_custom_dict_ok 0 + } + if {!$is_custom_dict_ok} { + error "frame option -type must be one of known types: $::textblock::frametypes or a dictionary with any of keys all,hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + } + if {[dict exists $f all]} { + return [tcl::dict::create category custom type $f] + } else { + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + set custom_frame [tcl::dict::merge $default_custom $f] + return [tcl::dict::create category custom type $custom_frame] + } + } + } + } + variable framedef_cache [tcl::dict::create] + proc framedef {args} { + #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. + #e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy. + #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. + #the arc set can't even join to itself e.g with curved equivalents of T-like shapes + + #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. + variable framedef_cache + set cache_key $args + if {[tcl::dict::exists $framedef_cache $cache_key]} { + return [tcl::dict::get $framedef_cache $cache_key] + } + + + #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. + #It also means we can't specify checks on the option types etc + set opts [tcl::dict::create\ + -joins ""\ + -boxonly 0\ + ] + set bad_option 0 + 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 $a2 [lindex $args [incr i]] + } + -- { + set values [lrange $args $i+1 end] + break + } + default { + if {[string match -* $a]} { + set bad_option 1 + } else { + set values [lrange $args $i end] + } + break + } + } + } + set f [lindex $values 0] + set rawglobs [lrange $values 1 end] + if {![llength $rawglobs] || "all" in $rawglobs || "*" in $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] { + @id -id ::textblock::framedef + @cmd -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 -optional 1 -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 + } + + set joins [tcl::dict::get $opts -joins] + set boxonly [tcl::dict::get $opts -boxonly] + + + #sorted order down left right up + #1 x choose 4 + #4 x choose 3 + #6 x choose 2 + #4 x choose 1 + #15 combos + + set join_directions [list] + #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode + #e.g down-light, up-heavy + set join_targets [tcl::dict::create left "" down "" right "" up ""] + foreach jt $joins { + lassign [split $jt -] direction target + if {$target ne ""} { + tcl::dict::set join_targets $direction $target + } + lappend join_directions $direction + } + set join_directions [lsort -unique $join_directions] + set do_joins [::join $join_directions _] + + + switch -- $f { + "altg" { + #old style ansi escape sequences with alternate graphics page G0 + set hl [cd::hl] + set hlt $hl + set hlb $hl + set vl [cd::vl] + set vll $vl + set vlr $vl + set tlc [cd::tlc] + set trc [cd::trc] + set blc [cd::blc] + set brc [cd::brc] + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + #No join targets available to join altg to other box styles + switch -- $do_joins { + down { + #1 + set blc [punk::ansi::g0 t] ;#(ltj) + set brc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } left { + #2 + set tlc [punk::ansi::g0 w] ;#(ttj) + set blc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + right { + #3 + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 v] ;#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + up { + #4 + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + } + down_left { + #5 + set blc [punk::ansi::g0 n] ;#(fwj) + set tlc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + down_right { + #6 + set blc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 n] ;#(fwj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_up { + #7 + set blc [punk::ansi::g0 t] ;#(ltj) + set brc [punk::ansi::g0 u] ;#(rtj) + + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set hltj [punk::ansi::g0 v];#(btj) + } + left_right { + #8 + #from 2 + set tlc [punk::ansi::g0 w] ;#(ttj) + set blc [punk::ansi::g0 v] ;#(btj) + #from3 + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + left_up { + #9 + set tlc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 u] ;#(rtj) + set blc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + right_up { + #10 + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 v] ;#(btj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_left_right { + #11 + set blc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 w] ;#(ttj) + set tlc [punk::ansi::g0 w] ;#(ttj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + down_left_up { + #12 + set tlc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 u] ;#(rtj) + set brc [punk::ansi::g0 u] ;#(rtj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + down_right_up { + #13 + set tlc [punk::ansi::g0 t] ;#(ltj) + set blc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + left_right_up { + #14 + set tlc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 v] ;#(btj) + set brc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_left_right_up { + #15 + set tlc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + } + + + } + "ascii" { + 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 $hlt + #set hlbj $hlb + #set vllj $vll + #set vlrj $vlr + #ascii + is small - can reasonably be considered a join to anything? + set hltj + + set hlbj + + set vllj + + set vlrj + + #our corners are all + already - so we won't do anything for directions or targets + + } + "light" { + #unicode box drawing set + set hl [punk::char::charshort boxd_lhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_lv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ldr] + set trc [punk::char::charshort boxd_ldl] + set blc [punk::char::charshort boxd_lur] + set brc [punk::char::charshort boxd_lul] + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #15 combos + #sort order: down left right up + #ltj,rtj,ttj,btj e.g left T junction etc. + #Look at from the perspective of a frame/table outline with a clean border and arms pointing inwards + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'light' + foreach dir {down left right up} { + 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 + } + ascii - altg - arc { + set target$dir light + } + heavy { + set target$dir $target + } + default { + set target$dir other + } + } + } + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + heavy { + set blc [punk::char::charshort boxd_dhrul] ;#\u251f down hieavy and right up light (ltj) + set brc \u2527 ;#boxd_dhlul down heavy and left up light (rtj) + set hlbj \u2530 ;# down heavy (ttj) + } + light { + set blc \u251c ;#[punk::char::charshort boxd_lvr] light vertical and right (ltj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set hlbj \u252c ;# (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + heavy { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + } + light { + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set vllj \u2524 ;# (rtj) + } + } + } + right { + #3 + switch -- $targetright { + heavy { + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + set vlrj \u251d;#right heavy (ltj) + } + light { + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set vlrj \u251c;# (ltj) + } + } + } + up { + #4 + switch -- $targetup { + heavy { + set tlc \u251e ;#up heavy (ltj) + set trc \u2526 ;#up heavy (rtj) + } + light { + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + other-light { + set blc \u2534 ;#(btj) + set tlc \u252c ;#(ttj) + #brc - default corner + set vllj \u2524 ;# (rtj) + } + other-other { + #default corners + } + other-heavy { + set blc \u2535 ;# heavy left (btj) + set tlc \u252d ;#heavy left (ttj) + #brc default corner + set vllj \u2525 ;# heavy left (rtj) + } + heavy-light { + set blc \u2541 ;# heavy down (fwj) + set tlc \u252c ;# light (ttj) + set brc \u2527 ;# heavy down (rtj) + set vllj \u2524 ;# (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + heavy-other { + set blc \u251f ;#heavy down (ltj) + #tlc - default corner + set brc \u2527 ;#heavy down (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + heavy-heavy { + set blc \u2545 ;#heavy down and left (fwj) + set tlc \u252d ;#heavy left (ttj) + set brc \u2527 ;#heavy down (rtj) + set vllj \u2525 ;# heavy left (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + light-light { + set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set tlc \u252c ;# boxd_ldhz (ttj) + set brc \u2524 ;# boxd_lvl light vertical and left(rtj) + set vllj \u2524 ;# (rtj) + set hlbj \u252c ;# (ttj) + } + light-other { + set blc \u251c ;# (ltj) + #tlc - default corner + set brc \u2524 ;# boxd_lvl (rtj) + set hlbj \u252c ;# (ttj) + } + light-heavy { + set blc \u253d ;# heavy left (fwj) + set tlc \u252d ;# heavy left (ttj) + set brc \u2524 ;# light (rtj) + set vllj \u2525 ;# heavy left (rtj) + set hlbj \u252c ;# (ttj) + } + default { + set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set tlc \u252c ;# [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc \u2524 ;# [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + } + } + down_right { + #6 + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + down_up { + #7 + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + left_right { + #8 + #from 2 + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + #from3 + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + + + switch -- $targetleft-$targetright { + heavy-light { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + set vlrj \u251c;#right light (ltj) + } + heavy-other { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + } + heavy-heavy { + set vllj \u2525 ;# left heavy (rtj) + set vlrj \u251d;#right heavy (ltj) + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + } + light-heavy { + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + set vlrj \u251d;#right heavy (ltj) + set vllj \u2524 ;# left light (rtj) + } + light-other { + set vllj \u2524 ;# left light (rtj) + } + light-light { + set vllj \u2524 ;# left light (rtj) + set vlrj \u251c;#right light (ltj) + } + } + #set vllj \u2525 ;# left heavy (rtj) + #set vllj \u2524 ;# left light (rtj) + #set vlrj \u251d;#right heavy (ltj) + #set vlrj \u251c;#right light (ltj) + } + left_up { + #9 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + } + right_up { + #10 + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + } + down_left_right { + #11 + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + + } + down_left_up { + #12 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + + } + down_right_up { + #13 + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + left_right_up { + #14 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + + } + down_left_right_up { + #15 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + } + #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 + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_hv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_hdr] + set trc [punk::char::charshort boxd_hdl] + set blc [punk::char::charshort boxd_hur] + set brc [punk::char::charshort boxd_hul] + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'heavy' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - heavy { + set target$dir heavy + } + light - ascii - altg - arc { + set target$dir light + } + default { + set target$dir other + } + } + } + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + light { + set blc [punk::char::charshort boxd_dlruh] ;#\u2521 down light and right up heavy (ltj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) + set hlbj \u252F ;#down light (ttj) + } + heavy { + set blc [punk::char::charshort boxd_hvr] ;# (ltj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set hlbj \u2533 ;# down heavy (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + light { + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) + set vllj \u2528 ;# left light (rtj) + } + heavy { + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + set vllj \u252b ;#(rtj) + } + } + } + right { + #3 + switch -- $targetright { + light { + set trc [punk::char::charshort boxd_rlldh] ;#\u2531 Right Light and Left Down Heavy (ttj) + set brc [punk::char::charshort boxd_rlluh] ;#\u2539 Right Light and Left Up Heavy(btj) + set vlrj \u2520 ;#right light (ltj) + } + heavy { + set trc [punk::char::charshort boxd_hdhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_huhz] ;# (btj) + set vlrj \u2523 ;# (ltj) + } + } + } + up { + #4 + switch -- $targetup { + light { + set tlc [punk::char::charshort boxd_ulrdh] ;#\u2522 Up Light and Right Down Heavy (ltj) + set trc [punk::char::charshort boxd_ulldh] ;#\u252a Up Light and Left Down Heavy (rtj) + set hltj \u2537 ;# up light (btj) + } + heavy { + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + set hltj \u253b ;# (btj) + } + } + } + down_left { + #down_left is the main join type used for 'L' shaped cell border table building where we boxlimit to {vll hlb blc} + #5 + switch -- down-$targetdown-left-$targetleft { + down-light-left-heavy { + set blc [punk::char::charshort boxd_dluhzh] ;#down light and up horizontal heavy (fwj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) (at tlc down stays heavy) + set hlbj \u252F ;# down light (ttj) + set vllj \u252b ;#(rtj) + } + down-heavy-left-light { + set blc [punk::char::charshort boxd_llrvh] ;# left light and right Vertical Heavy (fwj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) (at brc left must stay heavy) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set hlbj \u2533 ;# down heavy (ttj) + set vllj \u2528 ;# left light (rtj) + } + down-light-left-light { + set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) + set hlbj \u252F ;# down light (ttj) + set vllj \u2528 ;# left light (rtj) + } + down-heavy-left-heavy { + set blc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set hlbj \u2533 ;#(ttj) + set vllj \u252b ;#(rtj) + } + down-other-left-heavy { + set blc \u253b ;#boxd_huhz Heavy Up and Horizontal (btj) + #leave brc default corner + set tlc \u2533 ;#hdhz Heavy Down and Horizontal (ttj) + + set vllj \u252b ;#(rtj) + } + down-other-left-light { + set blc \u253a ;#llruh Left Light and Right Up Heavy (btj) + #leave brc default corner + set tlc \u2532 ;#llrdh Left Light and Right Down Heavy (ttj) + + set vllj \u2528 ;# left light (rtj) + } + down-heavy-left-other { + set blc \u2523 ;#hvr Heavy Vertical and Right (ltj) + set brc \u252b ;#hvl Heavy Veritcal and Left (rtj) + #leave tlc default corner + + set hlbj \u2533 ;#(ttj) + } + down-light-left-other { + set blc \u2521 ;#dlruh Down Light and Right Up Heavy (ltj) + set brc \u2529 ;#dlluh Down Light and Left Up Heavy (rtj) + #leave tlc default corner + + set hlbj \u252F ;# down light (ttj) + } + } + } + down_right { + #6 + set blc [punk::char::charshort boxd_hvr] ;# (ltj) (blc right&up stay heavy) + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) (tlc down&left stay heavy) + set brc [punk::char::charshort boxd_hvhz] ;# (fwj) (brc left&up heavy) + } + down_up { + #7 + set blc [punk::char::charshort boxd_hvr] ;# (ltj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + } + left_right { + #8 + #from 2 + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + #from3 + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) + set brc [punk::char::charshort boxd_huhz] ;# (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) + } + 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) + } + 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) + + } + 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) + + } + 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) + } + 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) + + } + 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) + } + } + } + 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 + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551 + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554 + set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557 + set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A + set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + # \u256c (fwj) + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'double' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - double { + set target$dir double + } + light { + set target$dir light + } + default { + set target$dir other + } + } + } + + #unicode provides no joining for double to anything else + #better to leave a gap by using default double corners if join target is not empty or double + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + double { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + set hlbj \u2566 ;# (ttj) + } + light { + set hlbj \u2564 ;# down light (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + double { + set tlc \u2566 ;# (ttj) + set blc \u2569 ;# (btj) + set vllj \u2563 ;# (rtj) + } + light { + set vllj \u2562 ;# light left (rtj) + } + } + } + right { + #3 + switch -- $targetright { + double { + set trc \u2566 ;# (ttj) + set brc \u2569 ;# (btj) + } + light { + set vlrj \u255F ;# light right (ltj) + } + } + } + up { + #4 + switch -- $targetup { + double { + set tlc \u2560 ;# (ltj) + set trc \u2563 ;# (rtj) + set hltj \u2569 ;# (btj) + } + light { + set hltj \u2567 ;#up light (btj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + double-double { + set blc \u256c ;# (fwj) + set brc \u2563 ;# (rtj) + set tlc \u2566 ;# (ttj) + set hlbj \u2566 ;# (ttj) + } + double-light { + #no corner joins treat corners like 'other' + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + + set hlbj \u2566 ;# (ttj) + set vllj \u2562 ;# light left (rtj) + + } + double-other { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + #leave tlc as ordinary double corner + } + light-double { + + set vllj \u2563 ;# (rtj) + set hlbj \u2564 ;# light down (ttj) + + } + light-light { + + set vllj \u2562 ;# light left (rtj) + set hlbj \u2564 ;# light down (ttj) + } + other-light { + set vllj \u2562 ;# light left (rtj) + } + other-double { + set blc \u2569 ;# (btj) + #leave brc as ordinary double corner + set tlc \u2566 ;# (ttj) + } + } + } + down_right { + #6 + switch -- $targetdown-$targetright { + double-double { + set blc \u2560 ;# (ltj) + set trc \u2566 ;# (ttj) + set brc \u256c ;# (fwj) + set hlbj \u2566 ;# (ttj) + } + double-other { + set blc \u2560 ;# (ltj) + #leave trc default + set brc \u2563 ;# (rtj) + } + other-double { + #leave blc default + set trc \u2566 ;# (ttj) + set brc \u2569 ;#(btj) + } + } + } + down_up { + #7 + switch -- $targetdown-$targetup { + double-double { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + set tlc \u2560 ;# (ltj) + set trc \u2563 ;# (rtj) + set hltj \u2569 ;# (btj) + set hlbj \u2566 ;# (ttj) + } + } + } + left_right { + #8 + + #from 2 + #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_ddhz] ;# (ttj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) + } + left_up { + #9 + 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_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_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_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_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_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_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) + } + } + + } + "arc" { + #unicode box drawing set + + + set hl [punk::char::charshort boxd_lhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_lv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D + set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E + set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 + set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'arc' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - arc { + set target$dir self + } + default { + set target$dir other + } + } + } + + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + self { + set blc \u251c ;# *light (ltj) + #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left + #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable + #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal + + #set brc \u2524 ;# *light(rtj) + #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) + } + } + } + left { + #2 + switch -- $targetleft { + self { + set tlc \u252c ;# *light(ttj) - need a low positioned curved y shape - nothing apparent + #set blc \u2144 ;# (btj) - upside down y - positioning too low for arc + set blc \u2534 ;# *light (btj) + } + } + } + right { + #3 + switch -- $targetright { + self { + set trc \u252c ;# *light (ttj) + #set brc \u2144 ;# (btj) + set brc \u2534 ;# *light (btj) + } + } + } + up { + #4 + switch -- $targetup { + self { + set tlc \u251c ;# *light (ltj) + set trc \u2524 ;# *light(rtj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + self-self { + #set blc \u27e1 ;# white concave-sided diamond - positioned too far right + #set blc \u27e3 ;# concave sided diamond with rightwards tick - positioned too low, too right - big gaps + #set blc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right + set brc \u2524 ;# *light (rtj) + set tlc \u252c ;# *light (ttj) + } + self-other { + #set blc \u2560 ;# (ltj) + #set brc \u2563 ;# (rtj) + #leave tlc as ordinary double corner + } + other-self { + #set blc \u2569 ;# (btj) + #leave brc as ordinary double corner + #set tlc \u2566 ;# (ttj) + } + } + } + down_right { + switch -- $targetdown-$targetright { + self-self { + #set brc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right + set trc \u252c ;# (ttj) + set blc \u2524 ;# (rtj) + } + } + } + } + } + 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 + set hlb \u2594 ;# upper one eighth block + set vll \u258f ;# left one eighth block + set vlr \u2595 ;# right one eighth block + set tlc \u2581 ;# lower one eighth block + set trc \u2581 ;# lower one eighth block + set blc \u2594 ;# upper one eighth block + set brc \u2594 ;# upper one eight block + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + } + block2 { + #the resultant table will have text appear towards top of each box + #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps + set hlt \u2594 ;# upper one eighth block + set hlb \u2581 ;# lower one eighth block + set vlr \u2595 ;# right one eighth block + set vll \u258f ;# left one eighth block + + #some terminals (on windows as at 2024) miscount width of these single-width blocks internally + #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) + #This was fixed in windows-terminal based systems (2021) but persists in others. + #https://github.com/microsoft/terminal/issues/11694 + set tlc \U1fb7d ;#legacy block + set trc \U1fb7e ;#legacy block + set blc \U1fb7c ;#legacy block + set brc \U1fb7f ;#legacy block + + if {[punk::console::check::has_bug_legacysymbolwidth]} { + #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems + set sp \u00a0 ;#non breaking space (plain space may act transparent in some use cases) + set tlc $sp + set trc $sp + set blc $sp + set brc $sp + } + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + } + block2hack { + #the resultant table will have text appear towards top of each box + #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps + set hlt \u2594 ;# upper one eighth block + set hlb \u2581 ;# lower one eighth block + set vlr \u2595 ;# right one eighth block + set vll \u258f ;# left one eighth block + + #see comments in block2 regarding the problems in some terminals that this *may* hack around to some extent. + #the caller probably only needs block2hack if block2 doesn't work + + #1) + #review - this hack looks sort of promising - but overtype::renderline needs fixing ? + #set tlc \U1fb7d\b ;#legacy block + #set trc \U1fb7e\b ;#legacy block + #set blc \U1fb7c\b ;#legacy block + #set brc \U1fb7f\b ;#legacy block + + #2) - works on cmd.exe and some others + # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones + #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) + #this hack has a reasonable chance of working + #except that the punk overtype library does recognise PMs + #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! + #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. + set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block + set trc \U1fb7e\x1b^\b\x1b\\ ;#legacy block + set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block + set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + } + block { + set hlt \u2580 ;#upper half + set hlb \u2584 ;#lower half + set vll \u258c ;#left half + set vlr \u2590 ;#right half + + set tlc \u259b ;#upper left corner half + set trc \u259c + set blc \u2599 + set brc \u259f + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + } + default { + #set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + if {"all" in [dict keys $f]} { + set A [dict get $f all] + set default_custom [tcl::dict::create hl $A vl $A tlc $A trc $A blc $A brc $A] + } + if {[llength $f] % 2} { + #todo - retrieve usage from punk::args + error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $::textblock::frametypes and does not appear to be a dictionary for a custom frametype" + } + #unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults + dict for {k v} $f { + switch -- $k { + all - hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} + default { + error "textblock::frametype '$f' has unknown element '$k'" + } + } + } + #verified keys - safe to extract as vars + set custom_frame [tcl::dict::merge $default_custom $f] + tcl::dict::with custom_frame {} ;#extract keys as vars + #longer j vars must be after their more specific counterparts in the list being processed by foreach + foreach t {hlt hlb vll vlr hltj hlbj vllj vlrj} { + if {[tcl::dict::exists $custom_frame $t]} { + set $t [tcl::dict::get $custom_frame $t] + } else { + #set more explicit type to it's more general counterpart if it's missing + #e.g hlt -> hl + #e.g hltj -> hlt + set $t [set [string range $t 0 end-1]] + } + } + #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set + #horizontal and vertical bar joins - key/variable ends with 'j' + } + } + if {$boxonly} { + set result [tcl::dict::create\ + tlc $tlc hlt $hlt trc $trc\ + vll $vll vlr $vlr\ + blc $blc hlb $hlb brc $brc\ + ] + } else { + set result [tcl::dict::create\ + tlc $tlc hlt $hlt trc $trc\ + vll $vll vlr $vlr\ + blc $blc hlb $hlb brc $brc\ + hltj $hltj\ + hlbj $hlbj\ + vllj $vllj\ + vlrj $vlrj\ + ] + } + 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] + + punk::args::define { + @id -id ::textblock::frame_cache + @cmd -name textblock::frame_cache -help\ + "Display or clear the frame cache." + -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 + } + proc frame_cache {args} { + set argd [punk::args::get_by_id ::textblock::frame_cache $args] + set action [dict get $argd opts -action] + + if {$action ni [list clear ""]} { + error "frame_cache action '$action' not understood. Valid actions: clear" + } + variable frame_cache + if {[dict get $argd opts -pretty]} { + set out [pdict -chan none frame_cache */*] + } else { + set out "" + if {[catch { + set termwidth [tcl::dict::get [punk::console::get_size] columns] + }]} { + set termwidth 80 + } + + tcl::dict::for {k v} $frame_cache { + lassign $v _f frame _used used + set fwidth [textblock::widthtopline $frame] + #review - are cached frames uniform width lines? + #set fwidth [textblock::width $frame] + set frameinfo "$k used:$used " + set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] + if {$allinone_width >= $termwidth} { + #split across 2 lines + append out "$frameinfo\n" + append out $frame \n + } else { + append out [textblock::join -- $frameinfo $frame]\n + } + append out \n ;# frames used to build tables often have joins - keep a line in between for clarity + } + } + if {$action eq "clear"} { + set frame_cache [tcl::dict::create] + append out \nCLEARED + } + return $out + } + + + variable FRAMETYPES + set FRAMETYPES [textblock::frametypes] + variable EG + set EG [a+ brightblack] + variable RST + set RST [a] + + proc frame_samples {} { + set FRAMETYPELABELS [dict create] + if {[info commands ::textblock::frame] ne ""} { + foreach ft [frametypes] { + dict set FRAMETYPELABELS $ft [textblock::frame -checkargs 0 -type $ft " "] + } + } + set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] + return $FRAMETYPELABELS + } + #proc EG {} "return {[a+ brightblack]}" + #make EG fetch from SGR cache so as to abide by colour off/on + proc EG {} { + a+ brightblack + } + #proc RST {} "return {\x1b\[m}" + proc RST {} { + return "\x1b\[m" + } + + #catch 22 for -choicelabels - need some sort of lazy evaluation + # ${[textblock::frame_samples]} + + #todo punk::args alias for centre center etc? + punk::args::define -dynamic 1 { + @id -id ::textblock::frame + @cmd -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 {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ + -choicelabels { + ${[textblock::frame_samples]} + }\ + -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. + ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::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. + ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${[textblock::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. + ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::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. + ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" + } + + #options before content argument - which is allowed to be absent + #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. + # + #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) + # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? + #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand + #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it + # - but we would need to maintain support for the rendered-string based operations too. + proc frame {args} { + variable frametypes + variable use_hash + + #counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var + set opts [tcl::dict::create\ + -etabs 0\ + -type light\ + -boxlimits [list hl vl tlc blc trc brc]\ + -boxmap {}\ + -joins [list]\ + -title ""\ + -subtitle ""\ + -width ""\ + -height ""\ + -ansiborder ""\ + -ansibase ""\ + -blockalign "centre"\ + -textalign "left"\ + -ellipsis 1\ + -usecache 1\ + -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 has_contents 0 + set optlist $args ;#initial only - content will be removed + #no solo opts for frame + if {[llength $args] %2 == 0} { + if {[lindex $args end-1] eq "--"} { + set contents [lpop optlist end] + set has_contents 1 + lpop optlist end ;#drop the end-of-opts flag + } else { + set optlist $args + set contents "" + } + } else { + set contents [lpop optlist 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} $optlist { + 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 + - -checkargs { + tcl::dict::set opts $k2 $v + } + default { + #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 + #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame + if {[llength $args] != 1 && (!$opts_ok || $check_args)} { + set argd [punk::args::get_by_id ::textblock::frame $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_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 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 opt_textalign [tcl::dict::get $opts -textalign] + + 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 + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + + lassign [textblock::frametype $opt_type] _cat category _type ftype + if {$category eq "custom"} { + set custom_frame $ftype + set frameset "custom" + set framedef $custom_frame + } else { + #category = predefined + set frameset $ftype ;# light,heavy etc + set framedef $ftype + } + + #if check_args? + + + #REVIEW - now done in framedef? + #set join_directions [list] + ##targets - light,heavy (double?) - seem to be some required glyphs missing from unicode + ##e.g down-light, up-heavy + #set join_targets [tcl::dict::create left "" down "" right "" up ""] + #foreach jt $opt_joins { + # lassign [split $jt -] direction target + # if {$target ne ""} { + # tcl::dict::set join_targets $direction $target + # } + # lappend join_directions $direction + #} + #set join_directions [lsort -unique $join_directions] + #set do_joins [::join $join_directions _] + + + + + # -- --- --- --- --- --- + + if {$has_contents} { + if {[tcl::string::last \t $contents] >= 0} { + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + if {$opt_etabs} { + #todo + set contents [textutil::tabify::untabify2 $contents $tw] + } + } + set contents [tcl::string::map {\r\n \n} $contents] + if {$opt_crm_mode} { + if {$opt_height eq ""} { + set h [textblock::height $contents] + } else { + set h [expr {$opt_height -2}] + } + if {$opt_width eq ""} { + set w [textblock::width $contents] + } else { + 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 + } + } else { + set actual_contentwidth 0 + set actual_contentheight 0 + } + + if {$opt_title ne ""} { + set titlewidth [punk::ansi::printing_length $opt_title] + set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}] + } else { + set titlewith 0 + set content_or_title_width $actual_contentwidth + } + #opt_subtitle ?? + + if {$opt_width eq ""} { + set frame_inner_width $content_or_title_width + } else { + set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default + } + + if {$opt_height eq ""} { + set frame_inner_height $actual_contentheight + } else { + set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default + } + if {$frame_inner_height == 0 && $frame_inner_width == 0} { + set has_contents 0 + } + #todo - render it with vertical overflow so we can process ansi moves? + #set linecount [textblock::height $contents] + set linecount $frame_inner_height + + # -- --- --- --- --- --- --- --- --- + variable frame_cache + #review - custom frame affects frame_inner_width - exclude from caching? + #set cache_key [concat $optlist $frame_inner_width $frame_inner_height] + #jmn + #set hashables [concat $optlist $frame_inner_width $frame_inner_height] + set hashables [list {*}$optlist $frame_inner_width $frame_inner_height] + + + switch -- $use_hash { + sha1 { + package require sha1 + set hash [sha1::sha1 [encoding convertto utf-8 $hashables]] + } + md5 { + package require md5 + if {[package vsatisfies [package present md5] 2- ] } { + set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review + } else { + set hash [md5::md5 [encoding convertto utf-8 $hashables]] + } + } + none { + set hash $hashables + } + } + + set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth" + #should be in a unicode private range different to that used in table construction + #e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts + #also supplementary private use blocks + #however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult) + #U+F0000 -> U+FFFD + #U+100000 -> U+10FFFD + #FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy) + #should be something someone is unlikely to use as part of a custom frame character. + #ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better) + #As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string + #terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like. + #e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never" + #review - we could consider wasting a few cycles to check for a conflict and use a different FSUB + set FSUB \uF2DD + + + #this occurs commonly in table building with colspans - review + if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { + set usecache 0 + #set buildcache 0 ;#comment out for debug/analysis so we can see + #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" + set cache_key [a+ Web-red web-white]$cache_key[a] + } + if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { + #colourise cache_key to warn + if {$actual_contentwidth == 0} { + #we can still substitute with right length + set cache_key [a+ Web-steelblue web-black]$cache_key[a] + } else { + #actual_contentwidth is narrower than frame - check template's patternwidth + if {[tcl::dict::exists $frame_cache $cache_key]} { + set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] + } else { + set cache_patternwidth $actual_contentwidth + } + if {$actual_contentwidth < $cache_patternwidth} { + set usecache 0 + set cache_key [a+ Web-orange web-black]$cache_key[a] + } elseif {$actual_contentwidth == $cache_patternwidth} { + #set usecache 1 + } else { + #actual_contentwidth > pattern + set usecache 0 + set cache_key [a+ Web-red web-black]$cache_key[a] + } + } + } + + #JMN debug + #set usecache 0 + + set is_cached 0 + if {$usecache && [tcl::dict::exists $frame_cache $cache_key]} { + set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] + set template [tcl::dict::get $frame_cache $cache_key frame] + set used [tcl::dict::get $frame_cache $cache_key used] + tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record + set is_cached 1 + } + + + # -- --- --- --- --- --- --- --- --- + if {!$is_cached} { + # -- --- --- --- --- + # -- --- --- --- --- + set is_joins_ok 1 + foreach v $opt_joins { + lassign [split $v -] direction target + switch -- $direction { + left - right - up - down {} + default { + set is_joins_ok 0 + break + } + } + switch -- $target { + "" - 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 + } + } + } + if {!$is_joins_ok} { + 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 + 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 + } + } + } + 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,hltj,hlbj,vllj,vlrj" + } + # -- --- --- --- --- --- + #these are all valid commands for overtype:: + switch -- $opt_textalign { + left - right - centre - center {} + default { + error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" + } + } + # -- --- --- --- --- --- + switch -- $opt_blockalign { + left - right - centre - center {} + default { + error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign" + } + } + # -- --- --- --- --- + # -- --- --- --- --- + set is_boxlimits_ok 1 + set exact_boxlimits [list] + foreach v $opt_boxlimits { + switch -- $v { + hl { + lappend exact_boxlimits hlt hlb + } + vl { + lappend exact_boxlimits vll vlr + } + hlt - hlb - vll - vlr - tlc - trc - blc - brc { + lappend exact_boxlimits $v + } + default { + #k not in custom_keys + set is_boxlimits_ok 0 + break + } + } + } + #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" + } + set exact_boxlimits [lsort -unique $exact_boxlimits] + # -- --- --- --- --- --- + + + set rst [a] + #set column [tcl::string::repeat " " $frame_inner_width] ;#default - may need to override for custom frame + set underlayline [tcl::string::repeat " " $frame_inner_width] + set underlay [::join [lrepeat $linecount $underlayline] \n] + + + set vll_width 1 ;#default for all except custom (printing width) + set vlr_width 1 + + set framedef [textblock::framedef -joins $opt_joins $framedef] + tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars + + #puts "---> $opt_boxmap" + #review - we handle double-wide in custom frames - what about for boxmaps? + tcl::dict::for {boxelement sub} $opt_boxmap { + if {$boxelement eq "vl"} { + set vll $sub + set vlr $sub + set hl $sub + } elseif {$boxelement eq "hl"} { + set hlt $sub + set hlb $sub + set hl $sub + } else { + set $boxelement $sub + } + } + + switch -- $frameset { + custom { + #REVIEW - textblock::table assumes that at least the vl elements are 1-wide + #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though + #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely + set vll_width [punk::ansi::printing_length $vll] + set hlb_width [punk::ansi::printing_length $hlb] + set hlt_width [punk::ansi::printing_length $hlt] + + set vlr_width [punk::ansi::printing_length $vlr] + + set tlc_width [punk::ansi::printing_length $tlc] + set trc_width [punk::ansi::printing_length $trc] + set blc_width [punk::ansi::printing_length $blc] + set brc_width [punk::ansi::printing_length $brc] + + + set framewidth [expr {$frame_inner_width + 2}] ;#reverse default assumption + if {$opt_width eq ""} { + #width wasn't specified - so user is expecting frame to adapt to title/contents + #content shouldn't truncate because of extra wide frame + #review - punk::console::get_size ? wrapping? quite hard to support with colspans + set frame_inner_width $content_or_title_width + set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width + set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] + } else { + set frame_inner_width [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated + set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}] + set bbarwidth [expr {$opt_width - $blc_width - $brc_width}] + } + #set column [tcl::string::repeat " " $frame_inner_width] + set underlayline [tcl::string::repeat " " $frame_inner_width] + set underlay [::join [lrepeat $linecount $underlayline] \n] + #cache? + + if {$hlt_width == 1} { + set tbar [tcl::string::repeat $hlt $tbarwidth] + } else { + #possibly mixed width chars that make up hlt - tcl::string::range won't get width right + set blank [tcl::string::repeat " " $tbarwidth] + if {$hlt_width > 0} { + set count [expr {($tbarwidth / $hlt_width) + 1}] + } else { + set count 0 + } + set tbar [tcl::string::repeat $hlt $count] + #set tbar [tcl::string::range $tbar 0 $tbarwidth-1] + set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character + } + if {$hlb_width == 1} { + set bbar [tcl::string::repeat $hlb $bbarwidth] + } else { + set blank [tcl::string::repeat " " $bbarwidth] + if {$hlb_width > 0} { + set count [expr {($bbarwidth / $hlb_width) + 1}] + } else { + set count 0 + } + set bbar [tcl::string::repeat $hlb $count] + #set bbar [tcl::string::range $bbar 0 $bbarwidth-1] + set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] + } + } + altg { + set tbar [tcl::string::repeat $hlt $frame_inner_width] + set tbar [cd::groptim $tbar] + set bbar [tcl::string::repeat $hlb $frame_inner_width] + set bbar [cd::groptim $bbar] + } + default { + set tbar [tcl::string::repeat $hlt $frame_inner_width] + set bbar [tcl::string::repeat $hlb $frame_inner_width] + + } + } + + set leftborder 0 + set rightborder 0 + set topborder 0 + set bottomborder 0 + # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + #puts "----->$exact_boxlimits" + foreach lim $exact_boxlimits { + switch -- $lim { + hlt { + set topborder 1 + } + hlb { + set bottomborder 1 + } + vll { + set leftborder 1 + } + vlr { + set rightborder 1 + } + tlc { + set topborder 1 + set leftborder 1 + } + trc { + set topborder 1 + set rightborder 1 + } + blc { + set bottomborder 1 + set leftborder 1 + } + brc { + set bottomborder 1 + set rightborder 1 + } + } + } + if {$opt_width ne "" && $opt_width < 2} { + set rightborder 0 + } + #keep lhs/rhs separate? can we do vertical text on sidebars? + set lhs [tcl::string::repeat $vll\n $linecount] + set lhs [tcl::string::range $lhs 0 end-1] + set rhs [tcl::string::repeat $vlr\n $linecount] + set rhs [tcl::string::range $rhs 0 end-1] + + + if {$opt_ansiborder ne ""} { + set tbar $opt_ansiborder$tbar$rst + set bbar $opt_ansiborder$bbar$rst + set tlc $opt_ansiborder$tlc$rst + set trc $opt_ansiborder$trc$rst + set blc $opt_ansiborder$blc$rst + set brc $opt_ansiborder$brc$rst + + set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out + set rhs $opt_ansiborder$rhs$rst + } + + #boxlimits used for partial borders in table generation + set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] + set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] + foreach lim $unspecified_limits { + switch -- $lim { + vll { + set blank_vll [tcl::string::repeat " " $vll_width] + set lhs [tcl::string::repeat $blank_vll\n $linecount] + set lhs [tcl::string::range $lhs 0 end-1] + } + vlr { + set blank_vlr [tcl::string::repeat " " $vlr_width] + set rhs [tcl::string::repeat $blank_vlr\n $linecount] + set rhs [tcl::string::range $rhs 0 end-1] + } + hlt { + set bar_width [punk::ansi::printing_length $tbar] + set tbar [tcl::string::repeat " " $bar_width] + } + tlc { + set tlc_width [punk::ansi::printing_length $tlc] + set tlc [tcl::string::repeat " " $tlc_width] + } + trc { + set trc_width [punk::ansi::printing_length $trc] + set trc [tcl::string::repeat " " $trc_width] + } + hlb { + set bar_width [punk::ansi::printing_length $bbar] + set bbar [tcl::string::repeat " " $bar_width] + } + blc { + set blc_width [punk::ansi::printing_length $blc] + set blc [tcl::string::repeat " " $blc_width] + } + brc { + set brc_width [punk::ansi::printing_length $brc] + set brc [tcl::string::repeat " " $brc_width] + } + } + } + + if {$opt_title ne ""} { + set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off + } else { + set topbar $tbar + } + if {$opt_subtitle ne ""} { + set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off + } else { + set bottombar $bbar + } + if {$opt_ansibase eq ""} { + set rstbase [a] + } else { + set rstbase [a]$opt_ansibase + } + + if {$opt_title ne ""} { + #title overrides -boxlimits for topborder + set topborder 1 + } + set fs "" + set fscached "" + set cache_patternwidth 0 + #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? + if {$topborder} { + if {$leftborder && $rightborder} { + append fs $tlc$topbar$trc + } else { + if {$leftborder} { + append fs $tlc$topbar + } elseif {$rightborder} { + append fs $topbar$trc + } else { + append fs $topbar + } + } + } + append fscached $fs + if {$has_contents || $opt_height > 2} { + #if {$topborder && $fs ne "xx"} { + # append fs \n + #} + if {$topborder} { + append fs \n + append fscached \n + } + switch -- $opt_textalign { + right {set pad "left"} + left {set pad "right"} + default {set pad $opt_textalign} + } + #set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1] + #set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents] + + set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth] + set cache_patternwidth $actual_contentwidth + set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] + set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] + #after overtype::block - our actual patternwidth may be less + set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] + + if {$leftborder && $rightborder} { + #set bodyparts [list $lhs $inner $rhs] + set cache_bodyparts [list $lhs $cache_inner $rhs] + } else { + if {$leftborder} { + #set bodyparts [list $lhs $inner] + set cache_bodyparts [list $lhs $cache_inner] + } elseif {$rightborder} { + #set bodyparts [list $inner $rhs] + set cache_bodyparts [list $cache_inner $rhs] + } else { + #set bodyparts [list $inner] + set cache_bodyparts [list $cache_inner] + } + } + #set body [textblock::join -- {*}$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 + } + + if {$opt_height eq "" || $opt_height > 1} { + if {$opt_subtitle ne ""} { + #subtitle overrides boxlimits for bottomborder + set bottomborder 1 + } + if {$bottomborder} { + if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { + #append fs \n + append fscached \n + } + if {$leftborder && $rightborder} { + #append fs $blc$bottombar$brc + append fscached $blc$bottombar$brc + } else { + if {$leftborder} { + #append fs $blc$bottombar + append fscached $blc$bottombar + } elseif {$rightborder} { + #append fs $bottombar$brc + append fscached $bottombar$brc + } else { + #append fs $bottombar + append fscached $bottombar + } + } + } + } + set template $fscached + ;#end !$is_cached + } + + + + + #use the same mechanism to build the final frame - whether from cache or template + if {$actual_contentwidth == 0} { + set fs [tcl::string::map [list $FSUB " "] $template] + } else { + set resultlines [list] + set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] + set contentindex 0 + switch -- $opt_textalign { + left {set pad right} + right {set pad left} + default {set pad $opt_textalign} + } + + #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] ""] ;# should not affect actual_contentwidth + } + + #set cwidth [textblock::width $contents] + set cwidth $actual_contentwidth + if {$opt_pad} { + 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} { + set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] + } + #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 { + if {$cwidth > $cache_patternwidth} { + set contents [overtype::renderspace -width $cache_patternwidth "" $contents] + } + set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line + } + + set tlines [split $template \n] + + #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. + #after textblock::join the reset will be a separate code ie should be exactly ESC[0m + set R [a] + set rlen [tcl::string::length $R] + set clines [split $contentblock \n] + + foreach tline $tlines { + if {[tcl::string::first $FSUB $tline] >= 0} { + set content_line [lindex $clines $contentindex] + if {[tcl::string::first $R [string range $content_line 0 10]] == 0} { + set content_line [tcl::string::range $content_line $rlen end] + } + #make sure to replay opt_ansibase to the right of the replacement + lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline] + incr contentindex + } else { + lappend resultlines $tline + } + } + set fs [::join $resultlines \n] + } + + + if {$is_cached} { + return $fs + } else { + if {$buildcache} { + tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] + } + return $fs + } + } + punk::args::define { + @id -id ::textblock::gcross + -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block + Only cross sizes that divide the size of the overall block will be used. + e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. + Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) + If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. + " + @values -min 0 -max 1 + size -default 1 -type integer + } + proc gcross {args} { + set argd [punk::args::get_by_id ::textblock::gcross $args] + set size [dict get $argd values size] + set opts [dict get $argd opts] + + if {$size == 0} { + return "" + } + + set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] + + #set fit_size [punk::lib::greatestOddFactor $size] + set fit_size $size + if {$opt_max_cross_size == 0} { + set max_cross_size $fit_size + } else { + #todo - only allow divisors + #set testsize [expr {min($fit_size,$opt_max_cross_size)}] + + set factors [punk::lib::factors $size] + #pick odd size in list that is smaller or equal to test_size + set max_cross_size [lindex $factors end] + set last_ok [lindex $factors 0] + for {set i 0} {$i < [llength $factors]} {incr i} { + set s [lindex $factors $i] + if {$s > $opt_max_cross_size} { + break + } + set last_ok $s + } + set max_cross_size $last_ok + } + set crosscount [expr {$size / $max_cross_size}] + + package require punk::char + set x [punk::char::charshort boxd_ldc] + set bs [punk::char::charshort boxd_ldgullr] + set fs [punk::char::charshort boxd_ldgurll] + + set onecross "" + set crossrows [list] + set armsize [expr {int(floor($max_cross_size /2))}] + set row [lrepeat $max_cross_size " "] + #toparm + for {set i 0} {$i < $armsize} {incr i} { + set r $row + lset r $i $bs + lset r end-$i $fs + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + + if {$max_cross_size % 2} { + #only put centre cross in for odd sized crosses + set r $row + lset r $armsize $x + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + + for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} { + set r $row + lset r $i $fs + lset r end-$i $bs + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + #set onecross [tcl::string::trimright $onecross \n] + set onecross [::join $crossrows \n] + + #fastest to do row first then columns - because textblock::join must do line by line + + if {$crosscount > 1} { + set row [textblock::join -- {*}[lrepeat $crosscount $onecross]] + set rows [lrepeat $crosscount $row] + set out [::join $rows \n] + } else { + set out $onecross + } + + return $out + } + + #Test we can join two coloured blocks + proc test_colour {} { + set b1 [a red]1\n2\n3[a] + set b2 [a green]a\nb\nc[a] + set result [textblock::join -- $b1 $b2] + puts $result + #return [list $b1 $b2 $result] + return [ansistring VIEW $result] + } + tcl::namespace::import ::punk::ansi::ansistrip +} + + +tcl::namespace::eval ::textblock::piper { + tcl::namespace::export * + proc join {rhs pipelinedata} { + tailcall ::textblock::join -- $pipelinedata $rhs + } +} +interp alias {} piper_blockjoin {} ::textblock::piper::join + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide textblock [tcl::namespace::eval textblock { + variable version + set version 0.1.3 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/argparsingtest-999999.0a1.0.tm b/src/modules/argparsingtest-999999.0a1.0.tm index 54aa05d7..57f8818d 100644 --- a/src/modules/argparsingtest-999999.0a1.0.tm +++ b/src/modules/argparsingtest-999999.0a1.0.tm @@ -296,7 +296,7 @@ namespace eval argparsingtest { return [tcl::dict::get $argd opts] } - punk::args::definition { + punk::args::define { @id -id ::test1_punkargs_by_id @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @opts -anyopts 0 @@ -318,7 +318,7 @@ namespace eval argparsingtest { return [tcl::dict::get $argd opts] } - punk::args::definition { + punk::args::define { @id -id ::argparsingtest::test1_punkargs2 @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @opts -anyopts 0 diff --git a/src/modules/patternpunk-1.1.tm b/src/modules/patternpunk-1.1.tm index 4f13a121..6611eee5 100644 --- a/src/modules/patternpunk-1.1.tm +++ b/src/modules/patternpunk-1.1.tm @@ -111,7 +111,8 @@ proc TCL {args} { return $version } -punk::args::definition { +punk::args::define { + #Review @id -id ">punk . poses" @cmd -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" diff --git a/src/modules/poshinfo-999999.0a1.0.tm b/src/modules/poshinfo-999999.0a1.0.tm index d8f7c059..aafd491e 100644 --- a/src/modules/poshinfo-999999.0a1.0.tm +++ b/src/modules/poshinfo-999999.0a1.0.tm @@ -198,7 +198,7 @@ tcl::namespace::eval poshinfo { error "unimplemented" } - punk::args::definition { + punk::args::define { @id -id ::poshinfo::themes @cmd -name poshinfo::themes -format -default all -multiple 1 -choices {all yaml json}\ diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 1a9ab766..08359461 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -12,6 +12,242 @@ namespace eval punk { #lazyload twapi ? catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later + + variable can_exec_windowsapp + set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed + variable windowsappdir + set windowsappdir "" + variable cmdexedir + set cmdexedir "" + + proc rehash {{refresh 0}} { + global auto_execs + if {!$refresh} { + unset -nocomplain auto_execs + } else { + set names [array names auto_execs] + unset -nocomplain auto_execs + foreach nm $names { + auto_execok_windows $nm + } + } + return + } + + + proc ::punk::auto_execok_original name [info body ::auto_execok] + variable better_autoexec + + #set better_autoexec 0 ;#use this var via better_autoexec only + #proc ::punk::auto_execok_windows name { + # ::punk::auto_execok_original $name + #} + + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + + set has_commandstack [expr {![catch {package require commandstack}]}] + if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} { + + #still a caching version of auto_execok - but with proper(fixed) search order + + #set b [info body ::auto_execok] + #proc ::auto_execok_original name $b + + proc better_autoexec {{onoff ""}} { + variable better_autoexec + if {$onoff eq ""} { + return $better_autoexec + } + if {![string is boolean -strict $onoff]} { + error "better_autoexec argument 'onoff' must be a boolean, received: $onoff" + } + if {$onoff && ($onoff != $better_autoexec)} { + puts "Turning on better_autoexec - search PATH first then extension" + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + punk::rehash + } elseif {!$onoff && ($onoff != $better_autoexec)} { + puts "Turning off better_autoexec - search extension then PATH" + set better_autoexec 0 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_original $name + } + punk::rehash + } else { + puts "no change" + } + } + #better_autoexec $better_autoexec ;#init to default + + + proc auto_execok_better name { + global auto_execs env tcl_platform + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + #puts stdout "[a+ red]...[a]" + set auto_execs($name) "" + + set shellBuiltins [list assoc cls copy date del dir echo erase exit ftype \ + md mkdir mklink move rd ren rename rmdir start time type ver vol] + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + if {[string tolower $name] in $shellBuiltins} { + # When this is command.com for some reason on Win2K, Tcl won't + # exec it unless the case is right, which this corrects. COMSPEC + # may not point to a real file, so do the check. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext $execExtensions { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + return "" + } + + #change1 + #set path "[file dirname [info nameofexecutable]];.;" + set path "[file dirname [info nameofexecutable]];" + + if {[info exists env(SystemRoot)]} { + set windir $env(SystemRoot) + } elseif {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + append path "$windir/system32;$windir/system;$windir;" + } + + foreach var {PATH Path path} { + if {[info exists env($var)]} { + append path ";$env($var)" + } + } + + #change2 + set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + foreach dir [split $path {;}] { + #set dir [file normalize $dir] + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} + + foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] { + set file [file join $dir $match] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + } + + #foreach ext $execExtensions { + #unset -nocomplain checked + #foreach dir [split $path {;}] { + # # Skip already checked directories + # if {[info exists checked($dir)] || ($dir eq "")} { + # continue + # } + # set checked($dir) {} + # set file [file join $dir ${name}${ext}] + # if {[file exists $file] && ![file isdirectory $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + #} + return "" + } + + + + #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? + #what if we create another interp and use the same ::auto_execs? The appdir won't be detected. + #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed + + + + #winget is installed on all modern windows and is an example of the problem this addresses + #we target apps with same location + + #the main purpose of this override is to support windows app executables (installed as 'reparse points') + #for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac + #versions prior to this will use cmd.exe to resolve the links + set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name { + #set windowsappdir "%appdir%" + upvar ::punk::can_exec_windowsapp can_exec_windowsapp + upvar ::punk::windowsappdir windowsappdir + upvar ::punk::cmdexedir cmdexedir + + if {$windowsappdir eq ""} { + #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' + #Tcl (2025) can't exec when given a path to these 0KB files + #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps + if {!([info exists ::env(LOCALAPPDATA)] && + [file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} { + #should be unlikely to get here - unless LOCALAPPDATA missing + set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]] + puts stderr "(resolved winget by search)" + } else { + set windowsappdir [file dirname $testapp] + } + } + + #set default_auto [$COMMANDSTACKNEXT $name] + set default_auto [::punk::auto_execok_windows $name] + #if {$name ni {cmd cmd.exe}} { + # unset -nocomplain ::auto_execs + #} + + if {$default_auto eq ""} { + return + } + set namedir [file dirname [lindex $default_auto 0]] + + if {$namedir eq $windowsappdir} { + if {$can_exec_windowsapp eq "unknown"} { + if {[catch {exec [file join $windowsappdir winget.exe] --version}]} { + set can_exec_windowsapp 0 + } else { + set can_exec_windowsapp 1 + } + } + if {$can_exec_windowsapp} { + return [file join $windowsappdir $name] + } + if {$cmdexedir eq ""} { + #cmd.exe very unlikely to move + set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] + #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index + #anyway.. it has other side effects (affects auto_load) + } + return "[file join $cmdexedir cmd.exe] /c $name" + } + return $default_auto + }] + + + } + } @@ -5321,8 +5557,8 @@ namespace eval punk { } return -options $opts $msg } else { - dict incr opts -level - return -options $opts $msg + dict incr opts -level + return -options $opts $msg } } } @@ -7152,7 +7388,7 @@ namespace eval punk { dict filter $result value {?*} } - punk::args::definition { + punk::args::define { @id -id ::punk::inspect @cmd -name punk::inspect -help\ "Function to display values - used pimarily in a punk pipeline. diff --git a/src/modules/punk/aliascore-999999.0a1.0.tm b/src/modules/punk/aliascore-999999.0a1.0.tm index 748e39a1..7da06446 100644 --- a/src/modules/punk/aliascore-999999.0a1.0.tm +++ b/src/modules/punk/aliascore-999999.0a1.0.tm @@ -115,6 +115,7 @@ tcl::namespace::eval punk::aliascore { pdict ::punk::lib::pdict\ plist {::punk::lib::pdict -roottype list}\ showlist {::punk::lib::showdict -roottype list}\ + rehash ::punk::rehash\ showdict ::punk::lib::showdict\ ansistrip ::punk::ansi::ansistrip\ stripansi ::punk::ansi::ansistrip\ diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 921b3ed1..24c4f1bf 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -5568,6 +5568,7 @@ tcl::namespace::eval punk::ansi::class { } #does not affect object state + #REVIEW - icu or equiv required method DoCount {plaintext} { #- combiners/diacritics just map them away here - but for consistency we need to combine unicode grapheme clusters too. #todo - joiners 200d? zwnbsp @@ -5672,6 +5673,7 @@ tcl::namespace::eval punk::ansi::class { method renderbuf {} { #get the underlying renderobj - if any #return $o_renderout ;#also class_ansistring + if {$o_renderer eq ""} {error "renderbuf error: no active renderer"} return [$o_renderer renderbuf] } method render {{maxgraphemes ""}} { diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index efb66a49..117f28fe 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -247,12 +247,12 @@ tcl::namespace::eval punk::args::register { tcl::namespace::eval punk::args { - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::definition at the end. + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. tcl::namespace::export {[a-z]*} variable argdata_cache variable argdefcache_by_id - variable argdefcache_unresolved + variable argdefcache_unresolved ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) variable id_counter set argdata_cache [tcl::dict::create] set argdefcache_by_id [tcl::dict::create] @@ -282,10 +282,18 @@ tcl::namespace::eval punk::args { set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::definition + @id -id ::punk::args::define #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::definition -help\ + @cmd -name punk::args::define -help\ "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + This can be used purely for documentation or called within a function to parse a mix of leading values, switches/flags and trailing values. @@ -427,10 +435,13 @@ tcl::namespace::eval punk::args { " @values -min 1 -max -1 text -type string -multiple 1 -help\ - "Block(s) of text representing the argument specification for a command. + "Block(s) of text representing the argument definition for a command. At least one must be supplied. If multiple, they are joined together with \\n. Using multiple text arguments may be useful to mix curly-braced and double-quoted strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + e.g the following definition passes 2 blocks as text arguments definition { @id -id ::myns::myfunc @@ -450,22 +461,135 @@ tcl::namespace::eval punk::args { } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" " }]] - proc definition {args} { + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -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_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + proc define {args} { variable argdata_cache variable argdefcache_by_id variable argdefcache_unresolved - #variable initial_optspec_defaults - #variable initial_valspec_defaults + set cache_key $args #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) #review - check if there is a built-into-tcl way to do this quickly #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. - set cache_key $args set textargs $args - + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } set is_dynamic 0 if {[lindex $args 0] eq "-dynamic"} { set is_dynamic [lindex $args 1] @@ -485,6 +609,8 @@ tcl::namespace::eval punk::args { set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] } } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] lassign $pt_params ptlist paramlist @@ -509,6 +635,7 @@ tcl::namespace::eval punk::args { tcl::dict::set argdefcache_unresolved $cache_key $pt_params } } + #argdata_cache should be limited in some fashion or will be a big memory leak??? if {[tcl::dict::exists $argdata_cache $optionspecs]} { #resolved cache version exists return [tcl::dict::get $argdata_cache $optionspecs] @@ -517,46 +644,6 @@ tcl::namespace::eval punk::args { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -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_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] #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 @@ -566,21 +653,14 @@ tcl::namespace::eval punk::args { #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 leader_required [list] set opt_required [list] set val_required [list] - set arg_info [tcl::dict::create] - set arg_checks [tcl::dict::create] set opt_defaults [tcl::dict::create] - set opt_names [list] ;#defined opts - set leader_defaults [tcl::dict::create] set val_defaults [tcl::dict::create] set opt_solos [list] - #first process dashed and non-dashed argspecs without regard to whether non-dashed are at the beginning or end - set leader_names [list] - set val_names [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end set records [list] set linebuild "" @@ -602,7 +682,7 @@ tcl::namespace::eval punk::args { foreach rawline $linelist { set recordsofar [tcl::string::cat $linebuild $rawline] #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in argspecs. + #review - when exactly are ansi codes allowed/expected in record lines. # - we might reasonably expect them in default values or choices or help strings # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. # - eg set line "set x \"a[a+ red]red[a]\"" @@ -656,48 +736,137 @@ tcl::namespace::eval punk::args { set id_info {} ;#e.g -children ?? set doc_info {} set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set parser_info {} - set leader_min "" - #set leader_min 0 - #set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - set leader_max "" + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" #(common case of no leaders specified) set opt_any 0 set val_min 0 set val_max -1 ;#-1 for no limit - set spec_id "" - set argspace "leaders" ;#leaders -> options -> values - set parser_id 0 - foreach ln $records { - set trimln [tcl::string::trim $ln] - switch -- [tcl::string::index $trimln 0] { + set DEF_definition_id "" + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { "" - # {continue} } - set linespecs [lassign $trimln argname] - if {[llength $linespecs] % 2 != 0} { - error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs' id:$spec_id" + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } } - set firstchar [tcl::string::index $argname 0] - set secondchar [tcl::string::index $argname 1] + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] if {$firstchar eq "@" && $secondchar ne "@"} { - set at_specs $linespecs + set record_type "directive" + set directive_name $firstword + set at_specs $record_values - switch -- [tcl::string::range $argname 1 end] { + switch -- [tcl::string::range $directive_name 1 end] { id { #id An id will be allocated if no id line present or the -id value is "auto" - if {$spec_id ne ""} { + if {$DEF_definition_id ne ""} { #disallow duplicate @id line - error "punk::args::definition - @id already set. Existing value $spec_id" + error "punk::args::define - @id already set. Existing value $DEF_definition_id" } if {[dict exists $at_specs -id]} { - set spec_id [dict get $at_specs -id] + set DEF_definition_id [dict get $at_specs -id] } else { - set spec_id auto + set DEF_definition_id auto } set id_info $at_specs } + ref { + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } default { - #copy from an identified set of defaults (another argspec id) can be multiple + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define -dynamic 1 making *immediate* resolutions .. is that really desirable? + if {[dict exists $at_specs -id]} { set copyfrom [get_def [dict get $at_specs -id]] #we don't copy the @id info from the source @@ -711,20 +880,27 @@ tcl::namespace::eval punk::args { if {![dict size $doc_info]} { set doc_info [dict get $copyfrom doc_info] } - if {![dict size $argdisplay_info]} { - set argdisplay_info [dict get $copyfrom argdisplay_info] + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? } - #TODO - #create leaders opts vals depending on position of @default line? - #options on @default line to exclude/include sets??? } } } - parser { + form { + # arity system ? #handle multiple parsing styles based on arities and keyword positions (and/or flags?) #e.g see lseq manual with 3 different parsing styles. #aim to produce a table/subtable for each - # *parser -description "start ?('..'|'to')? end ??'by'? step?"\ + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ # -arities { # 2 # {3 anykeys {1 .. 1 to}} @@ -733,24 +909,36 @@ tcl::namespace::eval punk::args { # }\ # -fallback 1 # ... - # *parser -description "start 'count' count ??'by'? step?"\ + # @parser -synopsis "start 'count' count ??'by'? step?"\ # -arities { # {3 anykeys {1 count}} # } # ... - # *parser -description "count ?'by' step?"\ + # @form -synopsis "count ?'by' step?"\ # -arities { # 1 # {3 anykeys {1 by}} # } # # see also after manual - # *parser -arities {1} - # *parser -arities { + # @form -arities {1} + # @form -arities { # 1 anykeys {0 info} # } #todo - set parser_info $at_specs + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) } cmd { #allow arbitrary - review @@ -765,475 +953,644 @@ tcl::namespace::eval punk::args { set argdisplay_info [dict merge $argdisplay_info $at_specs] } opts { - if {$argspace eq "values"} { - error "punk::args::definition - @opts declaration must come before @values - received '$linespecs' id:$spec_id" - } - set argspace "options" - foreach {k v} $at_specs { - switch -- $k { - -any - - -anyopts { - set opt_any $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset optspec_defaults $k2 + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 } - none - "" - - - any - ansistring - globstring - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" } - tcl::dict::set optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set optspec_defaults $k $v - } - default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @opts line. Known keys: $known id:$spec_id" } } - } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids } leaders { - if {$argspace in [list options values]} { - error "punk::args::definition - @leaders declaration must come before all options and values id:$spec_id" - } - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$spec_id" + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} } - set leader_min $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$spec_id" + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v } - set leader_max $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset leaderspec_defaults $k2 + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" } - tcl::dict::set leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set leaderspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @leaders line. Known keys: $known @id:$spec_id" } } - } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids } values { - set argspace "values" - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$spec_id" - } - set val_min $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$spec_id" - } - set val_max $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegoups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset valspec_defaults $k2 + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" } - bool - boolean { - set v bool + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" } - dict - dictionary { - set v dict + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegoups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 } - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" } - tcl::dict::set valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @values line. Known keys: $known @id:$spec_id" } } + dict set F $fid valspec_defaults $tmp_valspec_defaults } } default { - error "punk::args::definition - unrecognised @ line in '$ln'. Expected @id @cmd @leaders @opts or @values - use @@name if paramname needs to be @name @id:$spec_id" + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" } } + #record_type directive continue } elseif {$firstchar eq "-"} { - if {$argspace eq "leaders"} { - set argspace "options" - } elseif {$argspace eq "values"} { - error "punk::args::definition - invalid placement of line '$ln' - must come before @values @id:$spec_id" - } - set argspecs $linespecs - tcl::dict::set argspecs -ARGTYPE option - lappend opt_names $argname + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + set is_opt 1 } else { + set argname $firstword if {$firstchar eq "@"} { #allow basic @@ escaping for literal argname that begins with @ set argname [tcl::string::range $argname 1 end] } - set argspecs $linespecs - if {$argspace eq "leaders"} { - tcl::dict::set argspecs -ARGTYPE leader - lappend leader_names $argname - if {$leader_max >= 0} { - set leader_max [llength $leader_names] + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname } - } else { - tcl::dict::set argspecs -ARGTYPE value - lappend val_names $argname } + set is_opt 0 } + + #assert - we only get here if it is a value or flag specification line. - #assert argspecs has been set to the value of linespecs - if {$is_opt} { - set spec_merged $optspec_defaults - } else { - if {$argspace eq "values"} { - set spec_merged $valspec_defaults + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] } else { - set spec_merged $leaderspec_defaults + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } } - } - foreach {spec specval} $argspecs { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { - tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" } - lappend opt_solos $argname - } else { - #-solo only valid for flags - error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname' @id:$spec_id" } - } - 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] + 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 - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$spec_id" + -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$spec_id" + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" } } - } - default { - set known_argspecs [list -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - ] - error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs @id:$spec_id" - } - } - } - set argspecs $spec_merged - if {$is_opt} { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } else { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set arg_info $argname $argspecs - tcl::dict::set arg_checks $argname $argchecks - #review existence of -default overriding -optional - if {![tcl::dict::get $argspecs -optional] && ![tcl::dict::exists $argspecs -default]} { + } ;# end foreach {spec specval} argdef_values + + if {$is_opt} { - lappend opt_required $argname + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } else { - if {$argspace eq "leaders"} { - lappend leader_required $argname + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname } else { - lappend val_required $argname + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } } } - } - if {[tcl::dict::exists $argspecs -default]} { - if {$is_opt} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $argspecs -default] - } else { - if {$argspace eq "leaders"} { - tcl::dict::set leader_defaults $argname [tcl::dict::get $argspecs -default] + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $argspecs -default] + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } } } - } - } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + - if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { + if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { variable id_counter - set spec_id "autoid_[incr id_counter]" - } - - # REVIEW - #if {[llength $val_names] || $val_min > 0} { - # #some values are specified - # foreach leadername [lrange $leader_names 0 end] { - # if {[tcl::dict::get $arg_info $leadername -multiple]} { - # error "bad key -multiple on argument spec for leader '$leadername'. Last leader argument specification can be marked -multiple only when no values are specified" - # } - # } - #} else { + set DEF_definition_id "autoid_[incr id_counter]" + } + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW #no values specified - we can allow last leader to be multiple - foreach leadername [lrange $leader_names 0 end-1] { - if {[tcl::dict::get $arg_info $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple @id:$spec_id" + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" } } - #} - #confirm any valnames before last don't have -multiple key - foreach valname [lrange $val_names 0 end-1] { - if {[tcl::dict::get $arg_info $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple @id:$spec_id" + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - set leader_checks_defaults [tcl::dict::remove $leaderspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } set argdata_dict [tcl::dict::create\ - id $spec_id\ - arg_info $arg_info\ - arg_checks $arg_checks\ - leader_defaults $leader_defaults\ - leader_required $leader_required\ - leader_names $leader_names\ - leader_min $leader_min\ - leader_max $leader_max\ - leaderspec_defaults $leaderspec_defaults\ - leader_checks_defaults $leader_checks_defaults\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - opt_names $opt_names\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults $optspec_defaults\ - opt_checks_defaults $opt_checks_defaults\ - val_defaults $val_defaults\ - val_required $val_required\ - val_names $val_names\ - val_min $val_min\ - val_max $val_max\ - valspec_defaults $valspec_defaults\ - val_checks_defaults $val_checks_defaults\ - cmd_info $cmd_info\ - doc_info $doc_info\ - argdisplay_info $argdisplay_info\ - id_info $id_info\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + argdisplay_info $argdisplay_info\ + id_info $id_info\ + temp_F $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ ] + tcl::dict::set argdata_cache $cache_key $argdata_dict if {$is_dynamic} { #also cache resolved version tcl::dict::set argdata_cache $optionspecs $argdata_dict } - #tcl::dict::set argdefcache_by_id $spec_id $optionspecs - tcl::dict::set argdefcache_by_id $spec_id $args + #tcl::dict::set argdefcache_by_id $DEF_definition_id $optionspecs + tcl::dict::set argdefcache_by_id $DEF_definition_id $args #puts "xxx:$result" return $argdata_dict } - proc get_spec {id {patternlist *}} { + lappend PUNKARGS [list -dynamic 0 { + @id -id ::punk::args::get_spec + @cmd -name punk::args::get_definition -help\ + "" + id -type string -help\ + "identifer for punk::args defintion + This will usually be a fully-qualifed + path for a command name" + patternlist -type list -optional 1 -default * -help\ + "glob-style patterns for retrieving value or switch + definitions. If ommitted or passed an empty string, + the raw unresolved definition will be returned as + a list, including possible leading flags such as + -dynamic 0|1. + If specified as * - the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + " + override_dict -type dict -optional 1 -default "" -help\ + "unimplemented. + Will allow overriding or adding flags to a returned + definition line. + " + }] + #rename get_definition ??? + proc get_spec {id args} { + lassign $args patternlist override_dict + if {[llength $args] > 2} { + punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args] + return + } + if {[llength $override_dict] % 2 != 0} { + #malformed dict + punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args] + return + } + variable argdefcache_by_id set realid [real_id $id] if {$realid ne ""} { - if {$patternlist eq "*"} { - #todo? + if {$patternlist eq ""} { + #return the raw definition - possibly with unresolved dynamic parts return [tcl::dict::get $argdefcache_by_id $realid] } else { - set speclist [tcl::dict::get $argdefcache_by_id $realid] + set deflist [tcl::dict::get $argdefcache_by_id $realid] set result "" - set specdict [uplevel 1 [list ::punk::args::definition {*}$speclist]] - set arg_info [dict get $specdict arg_info] + set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]] + set arg_info [dict get $specdict ARG_INFO] foreach pat $patternlist { + if {[string match $pat @id]} { + #only a single id record can exist + append result \n "@id -id [dict get $specdict id]" + } + if {[string match $pat @cmd]} { + #only a single @cmd record can exist + #merged if multiple in original def (?) + append result \n "@cmd [dict get $specdict cmd_info]" + } + #todo @leaders, @opts, @values lines + #can be multiple of each. We need to preserve order and interleave + #with any matching arg_info results. + #requires storing more info in the internal spec dictionary set matches [dict keys $arg_info $pat] foreach m $matches { set def [dict get $arg_info $m] @@ -1250,9 +1607,9 @@ tcl::namespace::eval punk::args { set realid [real_id $id] if {$realid ne ""} { set speclist [tcl::dict::get $argdefcache_by_id $realid] - set specdict [definition {*}$speclist] - set arg_info [dict get $specdict arg_info] - set valnames [dict get $specdict val_names] + set specdict [define {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] set result "" if {$patternlist eq "*"} { foreach v $valnames { @@ -1280,7 +1637,7 @@ tcl::namespace::eval punk::args { proc get_def {id} { if {[id_exists $id]} { - return [definition {*}[get_spec $id]] + return [define {*}[get_spec $id]] } } proc is_dynamic {id} { @@ -1374,8 +1731,8 @@ tcl::namespace::eval punk::args { #puts -nonewline stderr . ;#debugging - see actual loads if {![catch { if {[info exists ${pkgns}::PUNKARGS]} { - foreach deflist [set ${pkgns}::PUNKARGS] { - namespace eval $pkgns [list punk::args::definition {*}$deflist] + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $pkgns [list punk::args::define {*}$definitionlist] } } if {[info exists ${pkgns}::PUNKARGS_aliases]} { @@ -1432,9 +1789,113 @@ tcl::namespace::eval punk::args { return $cmdinfo } + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::get_spec ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -choices {nocolour info error} + }] ] + #basic recursion blocker variable arg_error_isrunning 0 proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + if {[catch {package require punk::ansi}]} { proc punk::args::a {args} {} proc punk::args::a+ {args} {} @@ -1458,8 +1919,9 @@ tcl::namespace::eval punk::args { set badarg "" set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error + set scheme error dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return} $k] + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] switch -- $fullk { -badarg { set badarg $v @@ -1471,6 +1933,9 @@ tcl::namespace::eval punk::args { } set as_error $v } + -scheme { + set scheme $v + } -return { if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { set arg_error_isrunning 0 @@ -1484,6 +1949,68 @@ tcl::namespace::eval punk::args { } } } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. @@ -1510,13 +2037,13 @@ tcl::namespace::eval punk::args { append errmsg \n } else { if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)[a]" \n } else { append errmsg \n } } - set procname [Dict_getdef $spec_dict cmd_info -name ""] - set prochelp [Dict_getdef $spec_dict cmd_info -help ""] + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] set docurl [Dict_getdef $spec_dict doc_info -url ""] @@ -1531,18 +2058,18 @@ tcl::namespace::eval punk::args { set blank_header_col [list] - if {$procname ne ""} { + if {$cmdname ne ""} { lappend blank_header_col "" - set procname_display [a+ brightwhite]$procname[a] + set cmdname_display $CLR(cmdname)$cmdname[a] } else { - set procname_display "" + set cmdname_display "" } - if {$prochelp ne ""} { + if {$cmdhelp ne ""} { lappend blank_header_col "" - #set prochelp_display [a+ brightwhite]$prochelp[a] - set prochelp_display [textblock::ansibase_lines $prochelp [a+ white]] + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] } else { - set prochelp_display "" + set cmdhelp_display "" } if {$docurl ne ""} { lappend blank_header_col "" @@ -1550,11 +2077,25 @@ tcl::namespace::eval punk::args { } else { set docurl_display "" } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + if {$argdisplay_header ne ""} { lappend blank_header_col "" } if {$use_table} { - set t [textblock::class::table new [a+ brightyellow]Usage[a]] + set t [textblock::class::table new $CLR(title)Usage[a]] $t add_column -headers $blank_header_col -minwidth 3 $t add_column -headers $blank_header_col @@ -1573,19 +2114,19 @@ tcl::namespace::eval punk::args { } } set h 0 - if {$procname ne ""} { + if {$cmdname ne ""} { if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list PROC/METHOD: $procname_display] + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] } else { - lappend errlines "PROC/METHOD: $procname_display" + lappend errlines "COMMAND: $cmdname_display" } incr h } - if {$prochelp ne ""} { + if {$cmdhelp ne ""} { if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $prochelp_display] + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] } else { - lappend errlines "Description: $prochelp_display" + lappend errlines "Description: $cmdhelp_display" } incr h } @@ -1600,6 +2141,17 @@ tcl::namespace::eval punk::args { } incr h } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + if {$use_table} { if {$is_custom_argdisplay} { if {$argdisplay_header ne ""} { @@ -1632,11 +2184,13 @@ tcl::namespace::eval punk::args { set RST [a] #set A_DEFAULT [a+ brightwhite Brightgreen] set A_DEFAULT "" - set A_BADARG [a+ brightred] - set greencheck [a+ brightgreen]\u2713[a] ;#green tick - set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX [a+ green] ;#use a+ so colour off can apply - if {$A_PREFIX eq ""} { + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713[a] ;#green tick + set soloflag $CLR(solo)\u2690[a] ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead set A_PREFIX [a+ underline] set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space } else { @@ -1645,14 +2199,14 @@ tcl::namespace::eval punk::args { set opt_names [list] set opt_names_display [list] - if {[llength [dict get $spec_dict opt_names]]} { + 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 trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] set idents [dict get [$trie shortest_idents ""] scanned] #todo - check opt_prefixdeny $trie destroy - foreach c [dict get $spec_dict opt_names] { + foreach c [dict get $spec_dict OPT_NAMES] { set id [dict get $idents $c] #REVIEW if {$id eq $c} { @@ -1668,12 +2222,12 @@ tcl::namespace::eval punk::args { lappend opt_names $c } } else { - set opt_names [dict get $spec_dict opt_names] + set opt_names [dict get $spec_dict OPT_NAMES] set opt_names_display $opt_names } } - set leading_val_names [dict get $spec_dict leader_names] - set trailing_val_names [dict get $spec_dict val_names] + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { # if {![string match -* $argname]} { @@ -1695,7 +2249,7 @@ tcl::namespace::eval punk::args { lassign $argumentset argnames_display argnames foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict arg_info $arg] + set arginfo [dict get $spec_dict ARG_INFO $arg] if {[dict exists $arginfo -default]} { set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { @@ -1707,6 +2261,13 @@ tcl::namespace::eval punk::args { set choicegroups [Dict_getdef $arginfo -choicegroups {}] set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } if {[dict exists $choicegroups ""]} { dict lappend choicegroups "" {*}$choices } else { @@ -1827,12 +2388,11 @@ tcl::namespace::eval punk::args { #TODO -title directly in list_as_table set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] lappend choicetable_objects $choicetableobj - $choicetableobj configure -title [a+ cyan]$groupname + $choicetableobj configure -title $CLR(groupname)$groupname #append help \n[textblock::join -- " " [$choicetableobj print]] } else { if {$groupname ne ""} { - #bold as well as brightcolour in case colour off. - append help \n \n "[a+ brightyellow bold]Group: $groupname[a]" + append help \n \n "$CLR(groupname)Group: $groupname[a]" } else { append help \n } @@ -1846,15 +2406,15 @@ tcl::namespace::eval punk::args { if {$usetable} { #these will be displayed after all table entries if {$groupname eq ""} { - dict set choicetable_footers "" " [a+ red](no choices defined for main group)[a]" + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)[a]" } else { - dict set choicetable_footers $groupname " [a+ red](no choices defined for group $groupname)[a]" + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)[a]" } } else { if {$groupname eq ""} { - append help \n " " [a+ red](no choices defined)[a] + append help \n " " $CLR(errormsg)(no choices defined)[a] } else { - append help \n " " [a+ red](no choices defined for group $groupname)[a] + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)[a] } } } @@ -1896,13 +2456,16 @@ tcl::namespace::eval punk::args { } } } - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - set argshow "?${argshow}?" + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } } set typeshow [dict get $arginfo -type] if {$typeshow eq "none"} { @@ -1936,7 +2499,13 @@ tcl::namespace::eval punk::args { } ;#end is_custom_argdisplay if {$use_table} { - $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + $t configure -maxwidth 80 ;#review if {$returntype ne "tableobject"} { append errmsg [$t print] @@ -1976,7 +2545,7 @@ tcl::namespace::eval punk::args { } - lappend PUNKARGS [list { + lappend PUNKARGS [list -dynamic 1 { @id -id ::punk::args::usage @cmd -name punk::args::usage -help\ "Return usage information for a command. @@ -1989,6 +2558,7 @@ tcl::namespace::eval punk::args { mechanism and call this as necessary. " -return -default table -choices {string table tableobject} + } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} { @values -min 0 -max 1 id -help\ @@ -1998,11 +2568,12 @@ tcl::namespace::eval punk::args { proc usage {args} { lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received set id [dict get $values id] - set speclist [get_spec $id] - if {[llength $speclist] == 0} { + set definitionlist [get_spec $id] + if {[llength $definitionlist] == 0} { error "punk::args::usage - no such id: $id" } - arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] {*}$opts -aserror 0 + #by placing scheme before the supplied args - it can be overridden + arg_error "" [uplevel 1 [list punk::args::define {*}$definitionlist]] -scheme punk_info {*}$opts -aserror 0 } lappend PUNKARGS [list { @@ -2010,16 +2581,150 @@ tcl::namespace::eval punk::args { @cmd -name punk::args::get_by_id @values -min 1 id - arglist -default "" -type list -help\ + arglist -type list -help\ "list containing arguments to be parsed as per the argument specification identified by the supplied id." }] - proc get_by_id {id {arglist ""}} { - set speclist [punk::args::get_spec $id] - if {[llength $speclist] == 0} { + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::get_spec $id] + if {[llength $definitionlist] == 0} { error "punk::args::get_by_id - no such id: $id" } - return [uplevel 1 [list ::punk::args::get_dict {*}$speclist $arglist]] + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing + record that has been created with ::punk::args::define. + In the 'withdef' form - the definition is created on the + first call and cached thereafter. + + form1: parse ?-flag val?... -- $arglist withid $id + form2: parse ?-flag val?... -- $arglist withdef $def ?$def? + see punk::args::define" + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries. + " + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard minimal} + @values -min 3 + sep -optional 0 -choices "--" + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + set split [lsearch -exact $args --] ;#first -- + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. End of opts marker -- is required even if no options are present." + } + set opts [lrange $args 0 $split-1] ;#repeated flags will override earlier. That's ok here. + set arglist [lindex $args $split+1] + set tailtype [lindex $args $split+2] + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $args $split+3 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $split+3] + return "parse [llength $arglist] args withid $id, options:$opts" + } + withdef { + if {[llength [lrange $args $split+3 end]] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO } #todo? - a version of get_dict that directly supports punk::lib::tstr templating @@ -2031,6 +2736,15 @@ tcl::namespace::eval punk::args { #only supports -flag val pairs, not solo options #If an option is supplied multiple times - only the last value is used. proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + #*** !doctools #[call [fun get_dict] [arg optionspecs] [arg rawargs]] #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values @@ -2065,54 +2779,26 @@ tcl::namespace::eval punk::args { # @values -multiple 1 #} $args - #if {[llength $args] == 0} { - # set rawargs [list] - #} elseif {[llength $args] ==1} { - # set rawargs [lindex $args 0] ;#default tcl style - #} else { - # #todo - can we support tk style vals before flags? - # #the aim is to allow a single call to validate standard leading proc positional args along with the $args val which may have flags in tk or tcl order - # #by allowing all to be in a single call - we could use a -help (or similar erroring call) to trigger the spec-parsing from a wrapper function. - # #this would be important in the case where the function to be wrapped has never been called - but the wrapper needs info about the downstream options - # #we would like to avoid the ugliness of trying to parse a proc body to scrape the specification. - # #we may still need to do a basic scan of the proc body to determine if it at least contains the string punk::args::get_dict - but that is slightly less odious. - # error "unsupported number of arguments for punk::args::get_dict" - # set inopt 0 - # set k "" - # set i 0 - # foreach a $args { - # switch -- $f { - # -opts { - - # } - # -vals { - - # } - # -optvals { - # #tk style - - # } - # -valopts { - # #tcl style - # set rawargs [lindex $args $i+1] - # incr i - # } - # default { - - # } - # } - # incr i - # } - #} set is_dynamic 0 if {[lindex $args 0] eq "-dynamic"} { set is_dynamic [lindex $args 1] } set rawargs [lindex $args end] ;# args values to be parsed - set def_args [lrange $args 0 end-1] - set argspecs [uplevel 1 [list ::punk::args::definition {*}$def_args]] + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::define {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + #puts "-arg_info->$arg_info" set flagsreceived [list] ;#for checking if required flags satisfied #secondary purpose: @@ -2128,31 +2814,31 @@ tcl::namespace::eval punk::args { set opts $opt_defaults set pre_values {} - set argnames [tcl::dict::keys $arg_info] + set argnames [tcl::dict::keys $ARG_INFO] set optnames [lsearch -all -inline $argnames -*] set ridx 0 set rawargs_copy $rawargs set leader_posn_name "" set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) set is_multiple 0 ;#last leader may be multi - if {$leader_max != 0} { + if {$LEADER_MAX != 0} { foreach r $rawargs_copy { - if {$leader_max ne "" && $leader_max != -1 && $ridx > $leader_max-1} { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { break } - if {$ridx == [llength $leader_names]-1} { + if {$ridx == [llength $LEADER_NAMES]-1} { #at last named leader - set leader_posn_name [lindex $leader_names $ridx] - if {[dict exists $arg_info $leader_posn_name -multiple] && [dict get $arg_info $leader_posn_name -multiple]} { + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { set is_multiple 1 } - } elseif {$ridx > [llength $leader_names]-1} { + } elseif {$ridx > [llength $LEADER_NAMES]-1} { #beyond names - retain name if -multiple was true if {!$is_multiple} { set leader_posn_name "" } } else { - set leader_posn_name [lindex $leader_names $ridx] ;#may return empty string + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string } if {$r eq "--"} { #review end of opts marker: '--' can't be a leader (but can be a value) @@ -2181,7 +2867,7 @@ tcl::namespace::eval punk::args { #for each branch - break or lappend if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $leader_required} { + if {$leader_posn_name ni $LEADER_REQUIRED} { #optional leader #most adhoc arg processing will allocate based on number of args rather than matching choice values first @@ -2220,11 +2906,11 @@ tcl::namespace::eval punk::args { } } else { #unnamed leader - if {$leader_min ne "" } { - if {$ridx > $leader_min} { + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { break } else { - #haven't reached leader_min + #haven't reached LEADER_MIN lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } @@ -2234,16 +2920,24 @@ tcl::namespace::eval punk::args { } incr ridx - } + } ;# end foreach r $rawargs_copy } - if {$leader_min eq ""} { - set leader_min 0 + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN } - if {$leader_max eq ""} { - set leader_max -1 + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX } - #assert leader_max leader_min are numeric + #assert leadermax leadermin are numeric #assert - rawargs has been reduced by leading positionals set leaders [list] @@ -2251,7 +2945,7 @@ tcl::namespace::eval punk::args { set post_values {} #val_min, val_max #puts stderr "rawargs: $rawargs" - #puts stderr "arg_info: $arg_info" + #puts stderr "argstate: $argstate" if {[lsearch $rawargs -*] >= 0} { #at least contains flaglike things.. set maxidx [expr {[llength $rawargs] -1}] @@ -2298,9 +2992,9 @@ tcl::namespace::eval punk::args { } break } else { - set fullopt [tcl::prefix match -error "" $opt_names $a] + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] if {$fullopt ne ""} { - if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { #non-solo #check if it was actually a value that looked like a flag if {$i == $maxidx} { @@ -2312,7 +3006,7 @@ tcl::namespace::eval punk::args { } set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $argstate $fullopt -multiple]} { #don't lappend to default - we need to replace if there is a default if {$fullopt ni $flagsreceived} { tcl::dict::set opts $fullopt [list $flagval] @@ -2329,7 +3023,7 @@ tcl::namespace::eval punk::args { } } else { #solo - if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $argstate $fullopt -multiple]} { if {$fullopt ni $flagsreceived} { #override any default - don't lappend to it tcl::dict::set opts $fullopt 1 @@ -2359,10 +3053,10 @@ tcl::namespace::eval punk::args { if {$opt_any} { set newval [lindex $rawargs $i+1] #opt was unspecified but is allowed due to @opts -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::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { tcl::dict::lappend opts $a $newval } else { tcl::dict::set opts $a $newval @@ -2373,7 +3067,7 @@ tcl::namespace::eval punk::args { 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::get $argstate $a -multiple]} { if {![tcl::dict::exists $opts $a]} { tcl::dict::set opts $a 1 } else { @@ -2386,8 +3080,8 @@ tcl::namespace::eval punk::args { } lappend flagsreceived $a ;#adhoc flag as supplied } else { - if {[llength $opt_names]} { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" + if {[llength $OPT_NAMES]} { + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" } else { set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" } @@ -2419,15 +3113,15 @@ tcl::namespace::eval punk::args { set ldridx 0 set in_multiple "" set leadernames_received [list] - set leaders_dict $leader_defaults + set leaders_dict $LEADER_DEFAULTS set num_leaders [llength $leaders] - foreach leadername $leader_names ldr $leaders { + foreach leadername $LEADER_NAMES ldr $leaders { if {$ldridx+1 > $num_leaders} { break } if {$leadername ne ""} { - if {[tcl::dict::get $arg_info $leadername -multiple]} { - if {[tcl::dict::exists $leader_defaults $leadername]} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list } else { tcl::dict::lappend leaders_dict $leadername $ldr @@ -2443,8 +3137,8 @@ tcl::namespace::eval punk::args { lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) } else { tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set arg_info $positionalidx $leaderspec_defaults - tcl::dict::set arg_checks $positionalidx $leader_checks_defaults + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS lappend leadernames_received $positionalidx } } @@ -2457,12 +3151,12 @@ tcl::namespace::eval punk::args { set valnames_received [list] set values_dict $val_defaults set num_values [llength $values] - foreach valname $val_names val $values { + foreach valname $VAL_NAMES val $values { if {$validx+1 > $num_values} { break } if {$valname ne ""} { - if {[tcl::dict::get $arg_info $valname -multiple]} { + if {[tcl::dict::get $argstate $valname -multiple]} { if {[tcl::dict::exists $val_defaults $valname]} { #current stored val equals defined default - don't include default in the list we build up tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list @@ -2481,8 +3175,8 @@ tcl::namespace::eval punk::args { lappend valnames_received $in_multiple } else { tcl::dict::set values_dict $positionalidx $val - tcl::dict::set arg_info $positionalidx $valspec_defaults - tcl::dict::set arg_checks $positionalidx $val_checks_defaults + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS lappend valnames_received $positionalidx } } @@ -2490,17 +3184,17 @@ tcl::namespace::eval punk::args { incr positionalidx } - if {$leader_max == -1} { + if {$leadermax == -1} { #only check min - if {$num_leaders < $leader_min} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leader_min" $argspecs + if {$num_leaders < $leadermin} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs } } else { - if {$num_leaders < $leader_min || $num_leaders > $leader_max} { - if {$leader_min == $leader_max} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leader_min" $argspecs + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs } else { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leader_min and $leader_max inclusive" $argspecs + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs } } } @@ -2541,7 +3235,7 @@ tcl::namespace::eval punk::args { # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $leader_required $leadernames_received]]]} { + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs } if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { @@ -2560,9 +3254,9 @@ tcl::namespace::eval punk::args { set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash #puts "---opts_and_values:$opts_and_values" - #puts "---arg_info:$arg_info" + #puts "---argstate:$argstate" tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $arg_info $argname] + set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] set thisarg_checks [tcl::dict::get $arg_checks $argname] set is_multiple [tcl::dict::get $thisarg -multiple] @@ -3471,10 +4165,10 @@ tcl::namespace::eval punk::args::lib { #for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. #arguably it may be more processor-cache-efficient to do together like this anyway. -#can't do this - as there is circular dependency with punk::lib +#can't do this here? - as there is circular dependency with punk::lib #tcl::namespace::eval punk::args { # foreach deflist $PUNKARGS { -# punk::args::definition {*}$deflist +# punk::args::define {*}$deflist # } # set PUNKARGS "" #} diff --git a/src/modules/punk/args/tclcore-999999.0a1.0.tm b/src/modules/punk/args/tclcore-999999.0a1.0.tm index 8b6036ab..5c27d6b4 100644 --- a/src/modules/punk/args/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/tclcore-999999.0a1.0.tm @@ -208,7 +208,7 @@ tcl::namespace::eval punk::args::tclcore { #todo - make generic - take command and known_groups_dict proc info_subcommands {} { package require punk::ns - set subdict [punk::ns::ensemble_subcommands info] + set subdict [punk::ns::ensemble_subcommands -return dict info] set allsubs [dict keys $subdict] dict set groups "system" {hostname library nameofexecutable patchlevel script sharedlibextension tclversion} dict set groups "{proc introspection}" {args body default} @@ -234,8 +234,58 @@ tcl::namespace::eval punk::args::tclcore { } append argdef " \}" \n + #todo -choicelabels + #detect subcommand further info available e.g if oo or ensemble or punk::args id exists.. + #consider a different mechanism to add a label on rhs of same line as choice (for (i) marker) + return $argdef } + + + lappend PUNKARGS [list -dynamic 1 { + #test of @form + @id -id ::AFTER + @cmd -name "Builtin: after" -help\ + "Execute a command after a time delay." + + # ---------- shared elements ------------- + @ref -id common_script_help -help\ + "script argument to be concatenated in the same fashion as the concat command" + # ---------- shared elements ------------- + + @form -form {delay} -synopsis "after ms" + @form -form {schedule_ms} -synopsis "after ms ?script...?" + + #@values -form {*} #note "classify next argument as a value not a leader" + ms -form {*} -type int + @values -form {delay} -min 1 -max 1 + @values -form {schedule_ms} -min 2 + script -form {schedule_ms} -multiple 1 -optional 1 ref-help common_script_help + + + @form -form {cancelid} -synopsis "after cancel id" + @values + cancel -choices {cancel} + id + + + @form -form {cancelscript} -synopsis "after cancel script ?script...?" + @values -min 2 + cancel -choices {cancel} + script -multiple 1 -optional 0 ref-help common_script_help + + + @form -form {schedule_idle} -synopsis "after idle script ?script...?" + @values -min 1 + idle -choices {idle} + script -multiple 1 -optional 1 ref-help common_script_help + + @form -form {info} -synopsis "after info ?id?" + info -choices {info} + id -optional 1 + + } "@doc -name Manpage: -url [manpage_tcl after]" ] + lappend PUNKARGS [list -dynamic 1 { @id -id ::info @cmd -name "Builtin: info" -help\ @@ -290,11 +340,11 @@ tcl::namespace::eval punk::args::tclcore { characters are used. When decoding, upper and lower characters are accepted." } "@doc -name Manpage: -url [manpage_tcl binary]" ] lappend PUNKARGS [list { - @id -id "::tcl::binary::encode::hex" - @default -id (default)::tcl::binary::*::hex - @cmd -name "binary encode hex" - @values -min 1 -max 1 - data -type string + @id -id "::tcl::binary::encode::hex" + @default -id (default)::tcl::binary::*::hex + @cmd -name "binary encode hex" + @values -min 1 -max 1 + data -type string } ] lappend PUNKARGS [list { @id -id "::tcl::binary::decode::hex" @@ -534,7 +584,7 @@ tcl::namespace::eval punk::args::tclcore { value -type any -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl lappend]"] - punk::args::definition { + punk::args::define { @id -id ::ledit @cmd -name "builtin: ledit" -help\ "Replace elements of a list stored in variable @@ -547,7 +597,7 @@ tcl::namespace::eval punk::args::tclcore { value -type any -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl ledit]" - punk::args::definition { + punk::args::define { @id -id ::lpop @cmd -name "builtin: lpop" -help\ "Get and remove an element in a list @@ -567,7 +617,7 @@ tcl::namespace::eval punk::args::tclcore { in sublists, similar to lindex and lset." } "@doc -name Manpage: -url [manpage_tcl lpop]" - punk::args::definition { + punk::args::define { @id -id ::lrange @cmd -name "builtin: lrange" -help\ "return one or more adjacent elements from a list. @@ -587,23 +637,23 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl lrange]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::cat @cmd -name "builtin: tcl::string::cat" -help\ - "Concatente the given strings just like placing them directly next to each other and + "Concatenate the given strings just like placing them directly next to each other and return the resulting compound string. If no strings are present, the result is an empty string. This primitive is occasionally handier than juxtaposition of strings when mixed quoting is wanted, or when the aim is to return the result of a concatentation without resorting to return -level 0, and is more efficient than building a list of arguments and using join with an empty join string." - + @form -synopsis "string cat ?string...?" @values -min 0 -max -1 string -type string -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::compare @cmd -name "builtin: tcl::string::compare" -help\ @@ -623,7 +673,7 @@ tcl::namespace::eval punk::args::tclcore { string2 -type string } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::equal @cmd -name "builtin: tcl::string::equal" -help\ @@ -642,7 +692,7 @@ tcl::namespace::eval punk::args::tclcore { string2 -type string } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::first @cmd -name "builtin: tcl::string::first" -help\ "Search haystackString for a sequence of characters that exactly match the characters @@ -658,7 +708,7 @@ tcl::namespace::eval punk::args::tclcore { "integer or simple expression." } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::insert @cmd -name "builtin: tcl::string::insert" -help\ "Returns a copy of string with insertString inserted at the index'th character. @@ -679,7 +729,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::last @cmd -name "builtin: tcl::string::last" -help\ "Search haystackString for a sequence of characters that exactly match the characters @@ -695,7 +745,7 @@ tcl::namespace::eval punk::args::tclcore { "integer or simple expression." } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::repeat @cmd -name "builtin: tcl::string::repeat" -help\ "Returns a string consisting of string concatenated with itself count times." @@ -705,7 +755,7 @@ tcl::namespace::eval punk::args::tclcore { "If count is 0, the empty string will be returned." } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::replace @cmd -name "builtin: tcl::string::replace" -help\ "Removes a range of consecutive characters from string, starting with the character whose @@ -725,7 +775,7 @@ tcl::namespace::eval punk::args::tclcore { "If newstring is specified, then it is placed in the removed character range." } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::totitle @cmd -name "builtin: tcl::string::totitle" -help\ "Returns a value equal to string except that the first character in string is converted to @@ -740,7 +790,7 @@ tcl::namespace::eval punk::args::tclcore { "If last is specified, it refers to the char index in the string to stop at (inclusive)." } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::wordend @cmd -name "builtin: tcl::string::wordend" -help\ "Returns the index of the character just after the last one in the word containing @@ -756,7 +806,7 @@ tcl::namespace::eval punk::args::tclcore { e.g M+N" } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::wordstart @cmd -name "builtin: tcl::string::wordstart" -help\ "Returns the index of the first character in the word containing @@ -773,7 +823,7 @@ tcl::namespace::eval punk::args::tclcore { e.g M+N" } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition [punk::lib::tstr -return string { + punk::args::define [punk::lib::tstr -return string { @id -id ::tcl::string::is @cmd -name "builtin: tcl::string::is" -help\ "Returns 1 if string is a valid member of the specified character class, otherwise returns 0. @@ -932,7 +982,7 @@ tcl::namespace::eval punk::args::tclcore { string -type string -optional 0 }] "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::zlib @cmd -name "builtin: ::zlib" -help\ "zlib - compression and decompression operations @@ -960,7 +1010,7 @@ tcl::namespace::eval punk::args::tclcore { } } "@doc -name Manpage: -url [manpage_tcl zlib]" - punk::args::definition { + punk::args::define { @id -id "::zlib adler32" @cmd -name "builtin: ::zlib adler32" -help\ "Compute a checksum of binary string ${$I}string${$NI} using the Adler32 diff --git a/src/modules/punk/blockletter-999999.0a1.0.tm b/src/modules/punk/blockletter-999999.0a1.0.tm index a221675e..f159b327 100644 --- a/src/modules/punk/blockletter-999999.0a1.0.tm +++ b/src/modules/punk/blockletter-999999.0a1.0.tm @@ -119,7 +119,7 @@ tcl::namespace::eval punk::blockletter { set logo_letter_colours [list Web-red Web-green Web-royalblue Web-purple Web-orange] set logo_letter_colours [list Red Green Blue Purple Yellow] - punk::args::definition [tstr -return string { + punk::args::define [tstr -return string { @id -id ::punk::blockletter::logo -frametype -default {${$default_frametype}} -outlinecolour -default "web-white" @@ -218,7 +218,7 @@ tcl::namespace::eval punk::blockletter { append out [textblock::join_basic -- $left $centre $right] } - punk::args::definition [tstr -return string { + punk::args::define [tstr -return string { @id -id ::punk::blockletter::text -bgcolour -default "Web-red" -bordercolour -default "web-white" @@ -280,7 +280,9 @@ tcl::namespace::eval punk::blockletter::lib { #} - punk::args::definition [tstr -return string { + #use tstr when resolving params as a one-off at definition time + #versus slower -dynamic 1 if defaults/choices etc need to reflect the current state of the system. + punk::args::define [tstr -return string { @id -id ::punk::blockletter::block -height -default 2 -width -default 4 diff --git a/src/modules/punk/char-999999.0a1.0.tm b/src/modules/punk/char-999999.0a1.0.tm index c99d1a35..18061c84 100644 --- a/src/modules/punk/char-999999.0a1.0.tm +++ b/src/modules/punk/char-999999.0a1.0.tm @@ -1246,6 +1246,10 @@ tcl::namespace::eval punk::char { return [charset_dict "Box Drawing"] } + proc char_hex {char} { + return [format %08x [scan $char %c]] + } + proc char_info_hex {hex args} { set hex [tcl::string::map [list _ ""] $hex] if {[tcl::string::is xdigit -strict $hex]} { diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 3ca98adc..76305d9f 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -1186,7 +1186,7 @@ namespace eval punk::console { #todo - change -inoutchannels to -terminalobject with prebuilt default - punk::args::definition { + punk::args::define { @id -id ::punk::console::cell_size -inoutchannels -default {stdin stdout} -type list @values -min 0 -max 1 diff --git a/src/modules/punk/fileline-999999.0a1.0.tm b/src/modules/punk/fileline-999999.0a1.0.tm index be76cded..cc58ab3e 100644 --- a/src/modules/punk/fileline-999999.0a1.0.tm +++ b/src/modules/punk/fileline-999999.0a1.0.tm @@ -1251,7 +1251,7 @@ namespace eval punk::fileline { #[para] Core API functions for punk::fileline #[list_begin definitions] - punk::args::definition { + punk::args::define { @id -id ::punk::fileline::get_textinfo @cmd -name punk::fileline::get_textinfo -help\ "return: textinfo object instance" diff --git a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm index 6abe2c4e..b2eb5a93 100644 --- a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm @@ -26,7 +26,7 @@ package require punk::lib namespace eval punk::mix::commandset::loadedlib { namespace export * #search automatically wrapped in * * - can contain inner * ? globs - punk::args::definition { + punk::args::define { @id -id ::punk::mix::commandset::loadedlib::search @cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" -return -type string -default table -choices {table tableobject list lines} diff --git a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm index 8361b730..1e26a8bd 100644 --- a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm @@ -141,7 +141,7 @@ namespace eval punk::mix::commandset::module { set moduletypes [punk::mix::cli::lib::module_types] - punk::args::definition [subst { + punk::args::define [subst { @id -id ::punk::mix::commandset::module::new @cmd -name "punk::mix::commandset::module::new" -help\ "Create a new module file in the appropriate folder within src/modules. diff --git a/src/modules/punk/nav/fs-999999.0a1.0.tm b/src/modules/punk/nav/fs-999999.0a1.0.tm index 60baf233..4d2d27b3 100644 --- a/src/modules/punk/nav/fs-999999.0a1.0.tm +++ b/src/modules/punk/nav/fs-999999.0a1.0.tm @@ -636,7 +636,7 @@ tcl::namespace::eval punk::nav::fs { # c:/repo/jn/punk/../../blah #dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold # dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream - punk::args::definition { + punk::args::define { @id -id ::punk::nav::fs::dirfiles -stripbase -default 1 -type boolean -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" @@ -992,7 +992,7 @@ tcl::namespace::eval punk::nav::fs { return [dict merge $listing $updated] } - punk::args::definition { + punk::args::define { @id -id ::punk::nav::fs::dirfiles_dict_as_lines -stripbase -default 0 -type boolean -formatsizes -default 1 -type boolean diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index f043f92a..3007afde 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -1893,7 +1893,31 @@ tcl::namespace::eval punk::ns { } } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} $vline" set idauto "(autodef)$origin" - set argspec [punk::lib::tstr -return string { + set argdef [punk::lib::tstr -return string { @id -id ${$idauto} @cmd -name "Object: ${$origin}" -help\ "Instance of class: ${$class} (info autogenerated)" @values -min 1 }] - append argspec \n $vline - punk::args::definition $argspec + append argdef \n $vline + punk::args::define $argdef return [punk::args::usage {*}$opts $idauto] } privateObject { @@ -2457,7 +2502,8 @@ tcl::namespace::eval punk::ns { set match [tcl::prefix::match $subcommands [lindex $queryargs 0]] if {$match in $subcommands} { set subcmd [dict get $subcommand_dict $match] - return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + return [arginfo {*}$opts {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") } } @@ -2491,15 +2537,15 @@ tcl::namespace::eval punk::ns { set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] set autoid "(autodef)$origin" - set argspec [punk::lib::tstr -return string { + set argdef [punk::lib::tstr -return string { @id -id ${$autoid} @cmd -help\ "(autogenerated) ensemble: ${$origin}" @values -min 1 }] - append argspec \n $vline - punk::args::definition $argspec + append argdef \n $vline + punk::args::define $argdef return [punk::args::usage {*}$opts $autoid] } @@ -2918,7 +2964,7 @@ tcl::namespace::eval punk::ns { } interp alias "" use "" punk::ns::pkguse - punk::args::definition { + punk::args::define { @id -id ::punk::ns::nsimport_noclobber @cmd -name punk::ns::nsimport_noclobber -help\ "Import exported commands from a namespace into either the current namespace, diff --git a/src/modules/punk/path-999999.0a1.0.tm b/src/modules/punk/path-999999.0a1.0.tm index 7e6a0221..64e29077 100644 --- a/src/modules/punk/path-999999.0a1.0.tm +++ b/src/modules/punk/path-999999.0a1.0.tm @@ -644,7 +644,7 @@ namespace eval punk::path { return $ismatch } - punk::args::definition { + punk::args::define { @id -id ::punk::path::treefilenames -directory -type directory -help\ "folder in which to begin recursive scan for files." diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index 70c34c4a..9859ed8e 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -1580,7 +1580,7 @@ proc punk::repl::console_debugview {editbuf consolewidth args} { set spacepatch [textblock::block $debug_width $patch_height " "] puts -nonewline [punk::ansi::cursor_off] #use non cursorsave versions - cursor save/restore will interfere with any concurrent ansi rendering that uses save/restore - because save/restore is a single item, not a stack. - set debug_offset [[expr {$consolewidth - $debug_width - $opt_rightmargin}]] + set debug_offset [expr {$consolewidth - $debug_width - $opt_rightmargin}] set row_clear [expr {$opt_row -2}] punk::console::move_emitblock_return $row_clear $debug_offset $spacepatch punk::console::move_emitblock_return $opt_row $debug_offset $info diff --git a/src/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm index 9f77476c..76eed911 100644 --- a/src/modules/punk/repo-999999.0a1.0.tm +++ b/src/modules/punk/repo-999999.0a1.0.tm @@ -65,6 +65,22 @@ namespace eval punk::repo { variable PUNKARGS variable PUNKARGS_aliases + variable cached_command_paths + set cached_command_paths [dict create] + #anticipating possible removal of buggy caching from auto_execok + #mentioned in: https://core.tcl-lang.org/tcl/tktview/4dc35e0c0c + #this would leave the application to decide what it wants to cache in that regard. + proc Cached_auto_execok {name} { + return [auto_execok $name] + #variable cached_command_paths + #if {[dict exists $cached_command_paths $name]} { + # return [dict get $cached_command_paths $name] + #} + #set resolved [auto_execok $name] + #dict set cached_command_paths $name $resolved + #return $resolved + } + proc get_fossil_usage {} { set allcmds [runout -n fossil help -a] set mainhelp [runout -n fossil help] @@ -197,7 +213,7 @@ namespace eval punk::repo { #emit warning whether or not multiple fossil repos puts stdout [dict get $repostate warnings] } - set fossil_prog [auto_execok fossil] + set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog ne ""} { {*}$fossil_prog {*}$args } else { @@ -222,7 +238,10 @@ namespace eval punk::repo { #uppercase FOSSIL to bypass fossil as alias to fossil_proxy + #only necessary on unix? + #Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway proc establish_FOSSIL {args} { + #review if {![info exists ::auto_execs(FOSSIL)]} { set ::auto_execs(FOSSIL) [auto_execok fossil] ;#may fail in safe interp } @@ -499,7 +518,7 @@ namespace eval punk::repo { #For this reason we will store 'unchanged' records for both git and fossil so that the combined dict should represent all files in the revision if {$rt eq "fossil"} { dict set resultdict repotype fossil - set fossil_cmd [auto_execok fossil] + set fossil_cmd [Cached_auto_execok fossil] if {$fossil_cmd eq ""} { error "workingdir_state error: fossil executable doesn't seem to be available" } @@ -598,7 +617,7 @@ namespace eval punk::repo { break } elseif {$rt eq "git"} { dict set resultdict repotype git - set git_cmd [auto_execok git] + set git_cmd [Cached_auto_execok git] # -uno = suppress ? lines. # -b = show ranch and tracking info #our basic parsing/grepping assumes --porcelain=2 @@ -988,7 +1007,7 @@ namespace eval punk::repo { } proc fossil_get_repository_file {{path {}}} { if {$path eq {}} { set path [pwd] } - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set fossilinfo [::exec {*}$fossilcmd info] @@ -1073,7 +1092,7 @@ namespace eval punk::repo { set startdir $opt_parentfolder - set fossil_prog [auto_execok fossil] + set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog eq ""} { puts stderr "Fossil not found. Please install fossil" return @@ -1319,7 +1338,7 @@ namespace eval punk::repo { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[Cached_auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } @@ -1332,7 +1351,7 @@ namespace eval punk::repo { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[Cached_auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } @@ -1343,7 +1362,7 @@ namespace eval punk::repo { proc fossil_revision {{path {}}} { if {$path eq {}} { set path [pwd] } # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set info [::exec {*}$fossilcmd info] @@ -1357,7 +1376,7 @@ namespace eval punk::repo { proc fossil_remote {{path {}}} { if {$path eq {}} { set path [pwd] } # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set info [::exec {*}$fossilcmd remote ls] @@ -1423,7 +1442,7 @@ namespace eval punk::repo { set original_cwd [pwd] #attempt2 - let fossil do it for us - hopefully based on current folder if {$path eq {}} {set path [pwd]} - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {![llength $fossilcmd]} { set fossil_ok 0 } else { diff --git a/src/modules/punk/safe-999999.0a1.0.tm b/src/modules/punk/safe-999999.0a1.0.tm index d7369119..14024071 100644 --- a/src/modules/punk/safe-999999.0a1.0.tm +++ b/src/modules/punk/safe-999999.0a1.0.tm @@ -458,7 +458,7 @@ tcl::namespace::eval punk::safe { # If we have exactly 2 arguments the semantic is a "configure get" lassign $args child arg - set spec_dict [punk::args::definition [punk::args::get_spec punk::safe::interpIC]] + set spec_dict [punk::args::define [punk::args::get_spec punk::safe::interpIC]] set opt_names [dict get $spec_dict opt_names] CheckInterp $child @@ -761,7 +761,7 @@ tcl::namespace::eval punk::safe::system { append OPTS \n {-autoPath -type list -default {} -help\ "::auto_path for the child"} } - punk::args::definition $OPTS + punk::args::define $OPTS set optlines [punk::args::get_spec punk::safe::OPTS -*] set INTERPCREATE { @@ -775,7 +775,7 @@ tcl::namespace::eval punk::safe::system { } append INTERPCREATE \n $optlines append INTERPCREATE \n {@values -max 0} - punk::args::definition $INTERPCREATE + punk::args::define $INTERPCREATE set INTERPIC { @@ -786,7 +786,7 @@ tcl::namespace::eval punk::safe::system { } append INTERPIC \n $optlines append INTERPIC \n {@values -max 0} - punk::args::definition $INTERPIC + punk::args::define $INTERPIC #### diff --git a/src/modules/punk/sixel-999999.0a1.0.tm b/src/modules/punk/sixel-999999.0a1.0.tm index b60aa564..f69094fe 100644 --- a/src/modules/punk/sixel-999999.0a1.0.tm +++ b/src/modules/punk/sixel-999999.0a1.0.tm @@ -141,7 +141,7 @@ tcl::namespace::eval punk::sixel { #non-sixel characters ignored (? review) #we will for now consume all to final ST #TODO - sixel row/col info is dependent on terminal - pass in -terminalobject or -inoutchannels (for use with punk::console::cell_size) - punk::args::definition { + punk::args::define { @id -id ::punk::sixel::get_info @cmd -name punk::sixel::get_info -help\ "return a dict of information about the supplied sixelstring" diff --git a/src/modules/punk/winshell-999999.0a1.0.tm b/src/modules/punk/winshell-999999.0a1.0.tm new file mode 100644 index 00000000..2dc8e837 --- /dev/null +++ b/src/modules/punk/winshell-999999.0a1.0.tm @@ -0,0 +1,376 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::winshell 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::winshell 0 999999.0a1.0] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::winshell] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::winshell +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::winshell +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::winshell::class { + #*** !doctools + #[subsection {Namespace punk::winshell::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::winshell { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::winshell}] + #[para] Core API functions for punk::winshell + #[list_begin definitions] + + + #The windows api we need here is createPseudoConsole et al. + + variable autoshellid 0 + variable shellinfo [dict create] + + #test of exec and named pipes. + #we don't get a console + proc cmdexec {{id ""}} { + variable autoshellid + variable shellinfo + package require twapi + set pipebase {\\.\pipe\punkwinshell} + if {$id eq ""} { + incr autoshellid + set shellid $autoshellid + } else { + set shellid $id + } + + set pipename_stdin $pipebase$shellid-stdin + set pipename_stdout $pipebase$shellid-stdout + set pipename_stderr $pipebase$shellid-stderr + set h_stdin [twapi::namedpipe_server $pipename_stdin] ;#handle for child process redirection + set p_stdin [twapi::namedpipe_client $pipename_stdin] ;#this end + set h_stdout [twapi::namedpipe_server $pipename_stdout] ;#handle for child process redirection + set p_stdout [twapi::namedpipe_client $pipename_stdout] ;#this end + chan configure $p_stdout -blocking 0 + set h_stderr [twapi::namedpipe_server $pipename_stderr] ;#handle for child process redirection + set p_stderr [twapi::namedpipe_client $pipename_stderr] ;#this end + chan configure $p_stderr -blocking 0 + + set pid [exec cmd.exe /k >@$h_stdout 2>@$h_stderr <@$h_stdin &] + dict set shellinfo $shellid id $shellid + dict set shellinfo $shellid pid $pid + dict set shellinfo $shellid stdin $p_stdin + dict set shellinfo $shellid stdout $p_stdout + dict set shellinfo $shellid stderr $p_stderr + + return [dict get $shellinfo $shellid] + } + + #test with twapi create_process + proc cmdcreate {{id ""}} { + variable autoshellid + variable shellinfo + package require twapi + set pipebase {\\.\pipe\punkwinshell} + if {$id eq ""} { + incr autoshellid + set shellid $autoshellid + } else { + set shellid $id + } + + + #Method 1) - using windows named pipes + set pipename_stdin $pipebase$shellid-stdin + set pipename_stdout $pipebase$shellid-stdout + set pipename_stderr $pipebase$shellid-stderr + #set h_stdin [twapi::namedpipe_server $pipename_stdin] ;#handle for child process redirection - child to read + #set p_stdin [twapi::namedpipe_client $pipename_stdin] ;#this end for writing + + #set h_stdout [twapi::namedpipe_server $pipename_stdout] ;#handle for child process redirection - child to write + #set p_stdout [twapi::namedpipe_client $pipename_stdout] ;#this end for reading + #set h_stderr [twapi::namedpipe_server $pipename_stderr] ;#handle for child process redirection - child to write + #set p_stderr [twapi::namedpipe_client $pipename_stderr] ;#this end for reading + + #test + set p_stdout [twapi::namedpipe_server $pipename_stdout] ;#handle for child process redirection - child to write + set p_stdin "" + set p_stderr "" + chan configure $p_stdout -blocking 0 + + + #Method 2) - using tcl's 'chan pipe' which creates OS level channels + #chan pipe returns rd wr channels in that order + #lassign [chan pipe] h_stdin p_stdin + #lassign [chan pipe] p_stdout h_stdout + #lassign [chan pipe] p_stderr h_stderr + + #chan configure $p_stdout -blocking 0 + #chan configure $p_stderr -blocking 0 + + #set cmd {C:\Users\sleek\scoop\apps\windows-terminal\current\WindowsTerminal.exe} ;#doesn't work? + #set cmd "[auto_execok cmd.exe] /k" + #set cmd "[auto_execok powershell] -nop" + #set cmd "[auto_execok tclsh]" + set cmd "[auto_execok tclsh90]" + + set flagdict [dict create\ + -cmdline "$cmd"\ + -newconsole 1\ + -inherithandles 0\ + -background blue\ + -title "punk::winshell $shellid" + ] + + #dict set flagdict -stdchannels [list $h_stdin $h_stdout $h_stderr] + + set program "" + lassign [twapi::create_process $program {*}$flagdict] pid tid + + + puts stdout "launched with pid:$pid tid:$tid" + #set pid [exec cmd.exe /k >@$h_stdout 2>@$h_stderr <@$h_stdin &] + + dict set shellinfo $shellid id $shellid + dict set shellinfo $shellid pid $pid + dict set shellinfo $shellid type "create_process" + dict set shellinfo $shellid stdin $p_stdin + dict set shellinfo $shellid stdout $p_stdout + dict set shellinfo $shellid stderr $p_stderr + + return [dict get $shellinfo $shellid] + } + proc cmdexit {shellid} { + variable shellinfo + set info [dict get $shellinfo $shellid] + switch -- [dict get $info type] { + "create_process" { + set exitresult [twapi::end_process [dict get $info pid]] + } + "exec" { + puts stderr "todo.." + puts stderr "manually kill exec process [dict get $info pid]" + set exitresult 0 + } + } + return [dict create exitresult $exitresult] + } + + proc cmdkill {shellid} { + variable shellinfo + set info [dict get $shellinfo $shellid] + set pid [dict get $info pid] + set killcmd [list taskkill /PID $pid] + + if {[catch { + exec {*}$killcmd + } errMsg]} { + puts stderr "$killcmd returned an error:" + puts stderr $errMsg + #if {!$forcekill} { + # puts stderr "(try 'kill -9 $pid' ??)" + #} + + #review - *no running instance* works with windows taskkill - "*No such process*" works with kill -9 on FreeBSD and linux - other platforms? + if {![string match "*no running instance*" $errMsg] && ![string match "*No such process*" $errMsg]} { + lappend failed_kits [list kit $targetkit reason "could not kill running process for $targetkit (using '$killcmd')"] + continue + } else { + puts stderr " + } + } else { + puts stderr "$killcmd ran without error" + incr count_killed + } + + } + + proc cmdinfo {{id ""}} { + variable autoshellid + variable shellinfo + if {$id eq ""} { + #last created + set shellid $autoshellid + } else { + set shellid $id + } + set info [dict get $shellinfo $shellid] + set pid [dict get $info pid] + + set statusresult [tcl::process status $pid] + dict set info status $statusresult + set cmdline [twapi::get_process_commandline $pid] + dict set info cmdline $cmdline + return [showdict $info] + } + + #quick n dirty - status of last (or identified) winshell + proc cmdstat {{id ""}} { + variable autoshellid + variable shellinfo + if {$id eq ""} { + #last created + set shellid $autoshellid + } else { + set shellid $id + } + set pid [dict get $shellinfo $shellid pid] + set statusresult [tcl::process status $pid] + return [dict create id $shellid status $statusresult] + } + + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::winshell ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::winshell::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::winshell::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::winshell::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::winshell::system { + #*** !doctools + #[subsection {Namespace punk::winshell::system}] + #[para] Internal functions that are not part of the API + + + +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::winshell [tcl::namespace::eval punk::winshell { + variable pkg punk::winshell + variable version + set version 999999.0a1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/punk/winshell-buildversion.txt b/src/modules/punk/winshell-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/punk/winshell-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 8b03bb0d..7e8da071 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -4102,7 +4102,7 @@ tcl::namespace::eval textblock { return $t } - punk::args::definition { + punk::args::define { @id -id ::textblock::periodic @cmd -name textblock::periodic -help "A rudimentary periodic table This is primarily a test of textblock::class::table" @@ -4299,6 +4299,9 @@ tcl::namespace::eval textblock { set base "" set out "" if {$newprefix eq ""} { + if {![punk::ansi::ta::detect $block]} { + return $block + } foreach ln [split $block \n] { set parts [punk::ansi::ta::split_codes $ln] if {[lindex $parts 0] eq ""} { @@ -4325,6 +4328,12 @@ tcl::namespace::eval textblock { return [string range $out 0 end-1] } else { set base $newprefix + if {![punk::ansi::ta::detect $block]} { + foreach ln [split $block \n] { + append out $base $ln \n + } + return $out + } foreach ln [split $block \n] { set parts [punk::ansi::ta::split_codes $ln] set code_idx 1 @@ -4351,7 +4360,7 @@ tcl::namespace::eval textblock { } set FRAMETYPES [textblock::frametypes] - punk::args::definition [punk::lib::tstr -return string { + punk::args::define [punk::lib::tstr -return string { @id -id ::textblock::list_as_table @cmd -name "textblock::list_as_table" -help\ "Display a list in a bordered table @@ -4594,10 +4603,47 @@ tcl::namespace::eval textblock { return [::join $mtrx \n] } } - proc testblock {size {colour ""}} { - if {$size <1 || $size > 15} { - error "textblock::testblock only sizes between 1 and 15 inclusive supported" - } + + + punk::args::define { + @id -id ::textblock::testblock + @cmd -name textblock::testblock -help\ + "Create a block of characters size + columns wide and size rows tall. + (which on a terminal will show as a + vertically oriented rectangle due to + cells being taller than their width) + + The characters used are + 123456789ABCDEF + " + -size -type integer\ + -default 15\ + -optional 1\ + -range {1 15} + -direction -default horizontal\ + -choices {horizontal vertical}\ + -help\ + "When rainbow is in the colour list, + this also affects the direction of + colour changes" + @values -min 0 -max 2 + colour -type list -default {} -optional 1 -help\ + "List of Ansi colour names + e.g. testblock 10 {white Red} + produces a block of character 10x10 + with white text on red bacground + + The additional pseudo-color 'rainbow' + is available. + " + } + + proc testblock {args} { + set argd [punk::args::get_by_id ::textblock::testblock $args] + set colour [dict get $argd values colour] + set size [dict get $argd opts -size] + set rainbow_list [list] lappend rainbow_list {30 47} ;#black White lappend rainbow_list {31 46} ;#red Cyan @@ -4616,17 +4662,18 @@ tcl::namespace::eval textblock { lappend rainbow_list cyan lappend rainbow_list {white Red} - set rainbow_direction "horizontal" - set vpos [lsearch $colour vertical] - if {$vpos >= 0} { - set rainbow_direction vertical - set colour [lremove $colour $vpos] - } - set hpos [lsearch $colour horizontal] - if {$hpos >=0} { - #horizontal is the default and superfluous but allowed for symmetry - set colour [lremove $colour $hpos] - } + #set rainbow_direction "horizontal" + #set vpos [lsearch $colour vertical] + #if {$vpos >= 0} { + # set rainbow_direction vertical + # set colour [lremove $colour $vpos] + #} + #set hpos [lsearch $colour horizontal] + #if {$hpos >=0} { + # #horizontal is the default and superfluous but allowed for symmetry + # set colour [lremove $colour $hpos] + #} + set direction [dict get $argd opts -direction] @@ -4637,7 +4684,7 @@ tcl::namespace::eval textblock { } else { set RST [a] } - if {"rainbow" in $colour && $rainbow_direction eq "vertical"} { + if {"rainbow" in $colour && $direction eq "vertical"} { #column first - colour change each column set c [::join $charsubset \n] @@ -5431,7 +5478,7 @@ tcl::namespace::eval textblock { } - punk::args::definition { + punk::args::define { @id -id ::textblock::join_basic @cmd -name textblock::join_basic -help\ "Join blocks of text line by line but don't add padding on each line to enforce uniform width. @@ -7452,7 +7499,7 @@ tcl::namespace::eval textblock { variable frame_cache set frame_cache [tcl::dict::create] - punk::args::definition { + punk::args::define { @id -id ::textblock::frame_cache @cmd -name textblock::frame_cache -help\ "Display or clear the frame cache." @@ -7536,7 +7583,7 @@ tcl::namespace::eval textblock { # ${[textblock::frame_samples]} #todo punk::args alias for centre center etc? - punk::args::definition -dynamic 1 { + punk::args::define -dynamic 1 { @id -id ::textblock::frame @cmd -name "textblock::frame"\ -help "Frame a block of text with a border." @@ -8367,7 +8414,7 @@ tcl::namespace::eval textblock { foreach tline $tlines { if {[tcl::string::first $FSUB $tline] >= 0} { set content_line [lindex $clines $contentindex] - if {[tcl::string::first $R $content_line] == 0} { + if {[tcl::string::first $R [string range $content_line 0 10]] == 0} { set content_line [tcl::string::range $content_line $rlen end] } #make sure to replay opt_ansibase to the right of the replacement @@ -8390,7 +8437,7 @@ tcl::namespace::eval textblock { return $fs } } - punk::args::definition { + punk::args::define { @id -id ::textblock::gcross -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block Only cross sizes that divide the size of the overall block will be used. diff --git a/src/modules/textblock-buildversion.txt b/src/modules/textblock-buildversion.txt index 32568297..71fa630d 100644 --- a/src/modules/textblock-buildversion.txt +++ b/src/modules/textblock-buildversion.txt @@ -1,3 +1,3 @@ -0.1.2 +0.1.3 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm index d7d9813e..ee486569 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm @@ -211,6 +211,7 @@ namespace eval commandstack { set new_code [string trim $procbody] if {$current_code eq $new_code} { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [show_stack $command] } else { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." puts stdout "----------" @@ -223,6 +224,7 @@ namespace eval commandstack { } } else { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" + puts stderr set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid set do_rename 1 } @@ -374,13 +376,13 @@ namespace eval commandstack { proc show_stack {{commandname_glob *}} { variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } if {[package provide punk::lib] ne ""} { return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] } else { - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } set result "" set matchedkeys [dict keys $all_stacks $commandname_glob] #don't try to calculate widest on empty list diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm index 0d9cd0bc..fb044b3c 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm @@ -449,7 +449,7 @@ tcl::namespace::eval overtype { 4 { set inputchunks [list] foreach ln [split $overblock \n] { - lappend inputchunks [string cat $ln \n] + lappend inputchunks $ln\n } if {[llength $inputchunks]} { lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] @@ -499,9 +499,9 @@ tcl::namespace::eval overtype { #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set overtext $replay_codes_overlay$overtext if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::string::cat [tcl::dict::get $replay_codes_underlay $row] $undertext] + set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l @@ -1365,8 +1365,8 @@ tcl::namespace::eval overtype { set udiff [expr {$renderwidth - $ulen}] set undertext "$undertext[string repeat { } $udiff]" } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] #review - right-to-left langs should elide on left! - extra option required @@ -1518,8 +1518,8 @@ tcl::namespace::eval overtype { set startoffset 0 ;#negative? } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] if {$overflowlength > 0} { @@ -1545,7 +1545,7 @@ tcl::namespace::eval overtype { } } if {$show_ellipsis} { - set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] + set ellipsis $replay_codes$opt_ellipsistext #todo - overflow on left if allign = right?? set rendered [overtype::right $rendered $ellipsis] } @@ -1701,8 +1701,8 @@ tcl::namespace::eval overtype { set startoffset 0 ;#negative? } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] if {$overflowlength > 0} { @@ -1769,6 +1769,9 @@ tcl::namespace::eval overtype { return [join $outputlines \n] } + + variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. @@ -1802,6 +1805,7 @@ tcl::namespace::eval overtype { #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. #puts stderr "renderline '$args'" + variable optimise_ptruns if {[llength $args] < 2} { error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} @@ -1973,58 +1977,107 @@ tcl::namespace::eval overtype { foreach {pt code} $undermap { #pt = plain text #append pt_underchars $pt - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. - #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. - #todo - test decimal value instead, compare performance - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - set width 1 + if {$pt ne ""} { + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex + set re [tcl::string::cat {^[} \\U$hex {]+$}] + set is_ptrun [regexp $re $pt] + } + if {$is_ptrun} { + #switch -- $p1 { + # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + # set width 1 + # } + # default { + # if {$p1 eq "\u0000"} { + # #use null as empty cell representation - review + # #use of this will probably collide with some application at some point + # #consider an option to set the empty cell character + # set width 1 + # } else { + # set width [grapheme_width_cached $p1] ;# when zero??? + # } + # } + #} + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] + lappend undercols {*}[lrepeat $ptlen $p1] + } else { + incr i_u $ptlen ;#2nd col empty str - so same as above + set 2ptlen [expr {$ptlen * 2}] + lappend understacks {*}[lrepeat $2ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]] + lappend undercols {*}$l + unset l } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] - set grapheme $gvis + + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + set width 1 + } + default { + if {$grapheme eq "\u0000"} { + #use null as empty cell representation - review + #use of this will probably collide with some application at some point + #consider an option to set the empty cell character set width 1 + } else { + #zero width still acts as 1 below??? review what should happen + set width [grapheme_width_cached $grapheme] + #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length + #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI + #todo - default to off and add a flag (?) to enable this substitution + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. + set grapheme $gvis + set width 1 + } + } } } } + + #set width [grapheme_width_cached $grapheme] + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + + lappend undercols $grapheme + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + #but what about emoji combinations etc - can they be wider than 2? + #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + lappend undercols "" + } } - } - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" + } } - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2168,23 +2221,31 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left of the right number of columns. + #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpad_overlay [string repeat " " [expr {$opt_colstart -1}]] - append startpad_overlay $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - if {$startpad_overlay ne ""} { - if {[punk::ansi::ta::detect $startpad_overlay]} { - set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] + set startpadding [string repeat " " [expr {$opt_colstart -1}]] + #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + if {$startpadding ne "" || $overdata ne ""} { + if {[punk::ansi::ta::detect $overdata]} { + set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] } else { #single plaintext part - set overmap [list $startpad_overlay] + set overmap [list $startpadding$overdata] } } else { set overmap [list] } - #set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] #### + + #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) + #will that allow some optimisations? + + #todo - detect repeated transparent char in overlay + #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. + # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data + #we should be able to optimize to pass through the underlay?? + #??? set colcursor $opt_colstart #TODO - make a little virtual column object @@ -2206,41 +2267,78 @@ tcl::namespace::eval overtype { #experiment set overlay_grapheme_control_stacks [list] foreach {pt code} $overmap { - - #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - if {!$crm_mode} { - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack + if {$pt ne ""} { + #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] } - } else { - set tsbegin [clock micros] - foreach grapheme_original [punk::char::grapheme_split $pt] { - set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] - #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" - foreach grapheme [punk::char::grapheme_split $pt_crm] { - if {$grapheme eq "\n"} { + append pt_overchars $pt + #will get empty pt between adjacent codes + if {!$crm_mode} { + + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] + set is_ptrun [regexp $re $pt] + + #leading only? we would have to check for graphemes at the trailing boundary? + #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] + #set is_ptrun [regexp -indices $re $pt runrange] + #if {$is_ptrun && 1} { + #} + } + if {$is_ptrun} { + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) + set len [string length $pt] + set g_element [list g $p1] + + #lappend overstacks {*}[lrepeat $len $o_codestack] + #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] + #incr i_o $len + #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] + #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] + + set pi 0 + incr i_o $len + while {$pi < $len} { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + lappend overlay_grapheme_control_list $g_element lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] - } else { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack + incr pi + } + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_list [list g $grapheme] lappend overlay_grapheme_control_stacks $o_codestack } } + } else { + set tsbegin [clock micros] + foreach grapheme_original [punk::char::grapheme_split $pt] { + set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" + foreach grapheme [punk::char::grapheme_split $pt_crm] { + if {$grapheme eq "\n"} { + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] + } else { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } - set elapsed [expr {[clock micros] - $tsbegin}] - puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2324,6 +2422,7 @@ tcl::namespace::eval overtype { set o_codestack [list $temp_cursor_saved] lappend overlay_grapheme_control_list [list other $code] } else { + #review if {[punk::ansi::codetype::is_gx_open $code]} { set o_gxstack [list "gx0_on"] lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets @@ -2837,7 +2936,8 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] } 7CSI - 7OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + set codenorm $leadernorm[tcl::string::range $code 2 end] } 7DCS { #ESC P @@ -2849,7 +2949,8 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] } 7ESC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + set codenorm $leadernorm[tcl::string::range $code 1 end] } 8CSI - 8OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] @@ -2886,7 +2987,12 @@ tcl::namespace::eval overtype { A { #Row move - up set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set num $param + #todo + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} incr cursor_row -$num @@ -2904,9 +3010,12 @@ tcl::namespace::eval overtype { B { #CUD - Cursor Down #Row move - down - set num $param + lassign [split $param {;}] num modifierkey set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #move down + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} incr cursor_row $num @@ -2924,7 +3033,10 @@ tcl::namespace::eval overtype { #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. #cursor forward #right-arrow/move forward - set num $param + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} #todo - retrict to moving 1 position past datalen? restrict to column width? @@ -3028,7 +3140,10 @@ tcl::namespace::eval overtype { #puts stdout "<-back" #cursor back #left-arrow/move-back when ltr mode - set num $param + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} set version 2 @@ -4518,7 +4633,7 @@ tcl::namespace::eval overtype::priv { if {$existing eq "\0"} { lset o $i $c } else { - lset o $i [string cat $existing $c] + lset o $i $existing$c } } #is actually addgrapheme? diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm index 1a9ab766..08359461 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm @@ -12,6 +12,242 @@ namespace eval punk { #lazyload twapi ? catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later + + variable can_exec_windowsapp + set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed + variable windowsappdir + set windowsappdir "" + variable cmdexedir + set cmdexedir "" + + proc rehash {{refresh 0}} { + global auto_execs + if {!$refresh} { + unset -nocomplain auto_execs + } else { + set names [array names auto_execs] + unset -nocomplain auto_execs + foreach nm $names { + auto_execok_windows $nm + } + } + return + } + + + proc ::punk::auto_execok_original name [info body ::auto_execok] + variable better_autoexec + + #set better_autoexec 0 ;#use this var via better_autoexec only + #proc ::punk::auto_execok_windows name { + # ::punk::auto_execok_original $name + #} + + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + + set has_commandstack [expr {![catch {package require commandstack}]}] + if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} { + + #still a caching version of auto_execok - but with proper(fixed) search order + + #set b [info body ::auto_execok] + #proc ::auto_execok_original name $b + + proc better_autoexec {{onoff ""}} { + variable better_autoexec + if {$onoff eq ""} { + return $better_autoexec + } + if {![string is boolean -strict $onoff]} { + error "better_autoexec argument 'onoff' must be a boolean, received: $onoff" + } + if {$onoff && ($onoff != $better_autoexec)} { + puts "Turning on better_autoexec - search PATH first then extension" + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + punk::rehash + } elseif {!$onoff && ($onoff != $better_autoexec)} { + puts "Turning off better_autoexec - search extension then PATH" + set better_autoexec 0 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_original $name + } + punk::rehash + } else { + puts "no change" + } + } + #better_autoexec $better_autoexec ;#init to default + + + proc auto_execok_better name { + global auto_execs env tcl_platform + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + #puts stdout "[a+ red]...[a]" + set auto_execs($name) "" + + set shellBuiltins [list assoc cls copy date del dir echo erase exit ftype \ + md mkdir mklink move rd ren rename rmdir start time type ver vol] + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + if {[string tolower $name] in $shellBuiltins} { + # When this is command.com for some reason on Win2K, Tcl won't + # exec it unless the case is right, which this corrects. COMSPEC + # may not point to a real file, so do the check. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext $execExtensions { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + return "" + } + + #change1 + #set path "[file dirname [info nameofexecutable]];.;" + set path "[file dirname [info nameofexecutable]];" + + if {[info exists env(SystemRoot)]} { + set windir $env(SystemRoot) + } elseif {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + append path "$windir/system32;$windir/system;$windir;" + } + + foreach var {PATH Path path} { + if {[info exists env($var)]} { + append path ";$env($var)" + } + } + + #change2 + set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + foreach dir [split $path {;}] { + #set dir [file normalize $dir] + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} + + foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] { + set file [file join $dir $match] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + } + + #foreach ext $execExtensions { + #unset -nocomplain checked + #foreach dir [split $path {;}] { + # # Skip already checked directories + # if {[info exists checked($dir)] || ($dir eq "")} { + # continue + # } + # set checked($dir) {} + # set file [file join $dir ${name}${ext}] + # if {[file exists $file] && ![file isdirectory $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + #} + return "" + } + + + + #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? + #what if we create another interp and use the same ::auto_execs? The appdir won't be detected. + #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed + + + + #winget is installed on all modern windows and is an example of the problem this addresses + #we target apps with same location + + #the main purpose of this override is to support windows app executables (installed as 'reparse points') + #for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac + #versions prior to this will use cmd.exe to resolve the links + set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name { + #set windowsappdir "%appdir%" + upvar ::punk::can_exec_windowsapp can_exec_windowsapp + upvar ::punk::windowsappdir windowsappdir + upvar ::punk::cmdexedir cmdexedir + + if {$windowsappdir eq ""} { + #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' + #Tcl (2025) can't exec when given a path to these 0KB files + #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps + if {!([info exists ::env(LOCALAPPDATA)] && + [file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} { + #should be unlikely to get here - unless LOCALAPPDATA missing + set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]] + puts stderr "(resolved winget by search)" + } else { + set windowsappdir [file dirname $testapp] + } + } + + #set default_auto [$COMMANDSTACKNEXT $name] + set default_auto [::punk::auto_execok_windows $name] + #if {$name ni {cmd cmd.exe}} { + # unset -nocomplain ::auto_execs + #} + + if {$default_auto eq ""} { + return + } + set namedir [file dirname [lindex $default_auto 0]] + + if {$namedir eq $windowsappdir} { + if {$can_exec_windowsapp eq "unknown"} { + if {[catch {exec [file join $windowsappdir winget.exe] --version}]} { + set can_exec_windowsapp 0 + } else { + set can_exec_windowsapp 1 + } + } + if {$can_exec_windowsapp} { + return [file join $windowsappdir $name] + } + if {$cmdexedir eq ""} { + #cmd.exe very unlikely to move + set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] + #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index + #anyway.. it has other side effects (affects auto_load) + } + return "[file join $cmdexedir cmd.exe] /c $name" + } + return $default_auto + }] + + + } + } @@ -5321,8 +5557,8 @@ namespace eval punk { } return -options $opts $msg } else { - dict incr opts -level - return -options $opts $msg + dict incr opts -level + return -options $opts $msg } } } @@ -7152,7 +7388,7 @@ namespace eval punk { dict filter $result value {?*} } - punk::args::definition { + punk::args::define { @id -id ::punk::inspect @cmd -name punk::inspect -help\ "Function to display values - used pimarily in a punk pipeline. diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index c17bacf2..296bb6df 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -115,6 +115,7 @@ tcl::namespace::eval punk::aliascore { pdict ::punk::lib::pdict\ plist {::punk::lib::pdict -roottype list}\ showlist {::punk::lib::showdict -roottype list}\ + rehash ::punk::rehash\ showdict ::punk::lib::showdict\ ansistrip ::punk::ansi::ansistrip\ stripansi ::punk::ansi::ansistrip\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index a3f9c0b5..422c524e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -5568,6 +5568,7 @@ tcl::namespace::eval punk::ansi::class { } #does not affect object state + #REVIEW - icu or equiv required method DoCount {plaintext} { #- combiners/diacritics just map them away here - but for consistency we need to combine unicode grapheme clusters too. #todo - joiners 200d? zwnbsp @@ -5672,6 +5673,7 @@ tcl::namespace::eval punk::ansi::class { method renderbuf {} { #get the underlying renderobj - if any #return $o_renderout ;#also class_ansistring + if {$o_renderer eq ""} {error "renderbuf error: no active renderer"} return [$o_renderer renderbuf] } method render {{maxgraphemes ""}} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm index 2c9c77fa..78a18304 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm @@ -247,12 +247,12 @@ tcl::namespace::eval punk::args::register { tcl::namespace::eval punk::args { - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::definition at the end. + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. tcl::namespace::export {[a-z]*} variable argdata_cache variable argdefcache_by_id - variable argdefcache_unresolved + variable argdefcache_unresolved ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) variable id_counter set argdata_cache [tcl::dict::create] set argdefcache_by_id [tcl::dict::create] @@ -282,10 +282,18 @@ tcl::namespace::eval punk::args { set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::definition + @id -id ::punk::args::define #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::definition -help\ + @cmd -name punk::args::define -help\ "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + This can be used purely for documentation or called within a function to parse a mix of leading values, switches/flags and trailing values. @@ -427,10 +435,13 @@ tcl::namespace::eval punk::args { " @values -min 1 -max -1 text -type string -multiple 1 -help\ - "Block(s) of text representing the argument specification for a command. + "Block(s) of text representing the argument definition for a command. At least one must be supplied. If multiple, they are joined together with \\n. Using multiple text arguments may be useful to mix curly-braced and double-quoted strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + e.g the following definition passes 2 blocks as text arguments definition { @id -id ::myns::myfunc @@ -450,22 +461,135 @@ tcl::namespace::eval punk::args { } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" " }]] - proc definition {args} { + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -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_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + proc define {args} { variable argdata_cache variable argdefcache_by_id variable argdefcache_unresolved - #variable initial_optspec_defaults - #variable initial_valspec_defaults + set cache_key $args #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) #review - check if there is a built-into-tcl way to do this quickly #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. - set cache_key $args set textargs $args - + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } set is_dynamic 0 if {[lindex $args 0] eq "-dynamic"} { set is_dynamic [lindex $args 1] @@ -485,6 +609,8 @@ tcl::namespace::eval punk::args { set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] } } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] lassign $pt_params ptlist paramlist @@ -509,6 +635,7 @@ tcl::namespace::eval punk::args { tcl::dict::set argdefcache_unresolved $cache_key $pt_params } } + #argdata_cache should be limited in some fashion or will be a big memory leak??? if {[tcl::dict::exists $argdata_cache $optionspecs]} { #resolved cache version exists return [tcl::dict::get $argdata_cache $optionspecs] @@ -517,46 +644,6 @@ tcl::namespace::eval punk::args { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -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_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] #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 @@ -566,21 +653,14 @@ tcl::namespace::eval punk::args { #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 leader_required [list] set opt_required [list] set val_required [list] - set arg_info [tcl::dict::create] - set arg_checks [tcl::dict::create] set opt_defaults [tcl::dict::create] - set opt_names [list] ;#defined opts - set leader_defaults [tcl::dict::create] set val_defaults [tcl::dict::create] set opt_solos [list] - #first process dashed and non-dashed argspecs without regard to whether non-dashed are at the beginning or end - set leader_names [list] - set val_names [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end set records [list] set linebuild "" @@ -602,7 +682,7 @@ tcl::namespace::eval punk::args { foreach rawline $linelist { set recordsofar [tcl::string::cat $linebuild $rawline] #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in argspecs. + #review - when exactly are ansi codes allowed/expected in record lines. # - we might reasonably expect them in default values or choices or help strings # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. # - eg set line "set x \"a[a+ red]red[a]\"" @@ -656,48 +736,137 @@ tcl::namespace::eval punk::args { set id_info {} ;#e.g -children ?? set doc_info {} set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set parser_info {} - set leader_min "" - #set leader_min 0 - #set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - set leader_max "" + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" #(common case of no leaders specified) set opt_any 0 set val_min 0 set val_max -1 ;#-1 for no limit - set spec_id "" - set argspace "leaders" ;#leaders -> options -> values - set parser_id 0 - foreach ln $records { - set trimln [tcl::string::trim $ln] - switch -- [tcl::string::index $trimln 0] { + set DEF_definition_id "" + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { "" - # {continue} } - set linespecs [lassign $trimln argname] - if {[llength $linespecs] % 2 != 0} { - error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs' id:$spec_id" + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } } - set firstchar [tcl::string::index $argname 0] - set secondchar [tcl::string::index $argname 1] + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] if {$firstchar eq "@" && $secondchar ne "@"} { - set at_specs $linespecs + set record_type "directive" + set directive_name $firstword + set at_specs $record_values - switch -- [tcl::string::range $argname 1 end] { + switch -- [tcl::string::range $directive_name 1 end] { id { #id An id will be allocated if no id line present or the -id value is "auto" - if {$spec_id ne ""} { + if {$DEF_definition_id ne ""} { #disallow duplicate @id line - error "punk::args::definition - @id already set. Existing value $spec_id" + error "punk::args::define - @id already set. Existing value $DEF_definition_id" } if {[dict exists $at_specs -id]} { - set spec_id [dict get $at_specs -id] + set DEF_definition_id [dict get $at_specs -id] } else { - set spec_id auto + set DEF_definition_id auto } set id_info $at_specs } + ref { + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } default { - #copy from an identified set of defaults (another argspec id) can be multiple + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define -dynamic 1 making *immediate* resolutions .. is that really desirable? + if {[dict exists $at_specs -id]} { set copyfrom [get_def [dict get $at_specs -id]] #we don't copy the @id info from the source @@ -711,20 +880,27 @@ tcl::namespace::eval punk::args { if {![dict size $doc_info]} { set doc_info [dict get $copyfrom doc_info] } - if {![dict size $argdisplay_info]} { - set argdisplay_info [dict get $copyfrom argdisplay_info] + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? } - #TODO - #create leaders opts vals depending on position of @default line? - #options on @default line to exclude/include sets??? } } } - parser { + form { + # arity system ? #handle multiple parsing styles based on arities and keyword positions (and/or flags?) #e.g see lseq manual with 3 different parsing styles. #aim to produce a table/subtable for each - # *parser -description "start ?('..'|'to')? end ??'by'? step?"\ + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ # -arities { # 2 # {3 anykeys {1 .. 1 to}} @@ -733,24 +909,36 @@ tcl::namespace::eval punk::args { # }\ # -fallback 1 # ... - # *parser -description "start 'count' count ??'by'? step?"\ + # @parser -synopsis "start 'count' count ??'by'? step?"\ # -arities { # {3 anykeys {1 count}} # } # ... - # *parser -description "count ?'by' step?"\ + # @form -synopsis "count ?'by' step?"\ # -arities { # 1 # {3 anykeys {1 by}} # } # # see also after manual - # *parser -arities {1} - # *parser -arities { + # @form -arities {1} + # @form -arities { # 1 anykeys {0 info} # } #todo - set parser_info $at_specs + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) } cmd { #allow arbitrary - review @@ -765,475 +953,644 @@ tcl::namespace::eval punk::args { set argdisplay_info [dict merge $argdisplay_info $at_specs] } opts { - if {$argspace eq "values"} { - error "punk::args::definition - @opts declaration must come before @values - received '$linespecs' id:$spec_id" - } - set argspace "options" - foreach {k v} $at_specs { - switch -- $k { - -any - - -anyopts { - set opt_any $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset optspec_defaults $k2 + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 } - none - "" - - - any - ansistring - globstring - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" } - tcl::dict::set optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set optspec_defaults $k $v - } - default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @opts line. Known keys: $known id:$spec_id" } } - } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids } leaders { - if {$argspace in [list options values]} { - error "punk::args::definition - @leaders declaration must come before all options and values id:$spec_id" - } - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$spec_id" + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} } - set leader_min $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$spec_id" + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v } - set leader_max $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset leaderspec_defaults $k2 + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" } - tcl::dict::set leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set leaderspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @leaders line. Known keys: $known @id:$spec_id" } } - } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids } values { - set argspace "values" - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$spec_id" - } - set val_min $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$spec_id" - } - set val_max $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegoups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset valspec_defaults $k2 + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" } - bool - boolean { - set v bool + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" } - dict - dictionary { - set v dict + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegoups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 } - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" } - tcl::dict::set valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @values line. Known keys: $known @id:$spec_id" } } + dict set F $fid valspec_defaults $tmp_valspec_defaults } } default { - error "punk::args::definition - unrecognised @ line in '$ln'. Expected @id @cmd @leaders @opts or @values - use @@name if paramname needs to be @name @id:$spec_id" + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" } } + #record_type directive continue } elseif {$firstchar eq "-"} { - if {$argspace eq "leaders"} { - set argspace "options" - } elseif {$argspace eq "values"} { - error "punk::args::definition - invalid placement of line '$ln' - must come before @values @id:$spec_id" - } - set argspecs $linespecs - tcl::dict::set argspecs -ARGTYPE option - lappend opt_names $argname + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + set is_opt 1 } else { + set argname $firstword if {$firstchar eq "@"} { #allow basic @@ escaping for literal argname that begins with @ set argname [tcl::string::range $argname 1 end] } - set argspecs $linespecs - if {$argspace eq "leaders"} { - tcl::dict::set argspecs -ARGTYPE leader - lappend leader_names $argname - if {$leader_max >= 0} { - set leader_max [llength $leader_names] + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname } - } else { - tcl::dict::set argspecs -ARGTYPE value - lappend val_names $argname } + set is_opt 0 } + + #assert - we only get here if it is a value or flag specification line. - #assert argspecs has been set to the value of linespecs - if {$is_opt} { - set spec_merged $optspec_defaults - } else { - if {$argspace eq "values"} { - set spec_merged $valspec_defaults + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] } else { - set spec_merged $leaderspec_defaults + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } } - } - foreach {spec specval} $argspecs { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { - tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" } - lappend opt_solos $argname - } else { - #-solo only valid for flags - error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname' @id:$spec_id" } - } - 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] + 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 - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$spec_id" + -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$spec_id" + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" } } - } - default { - set known_argspecs [list -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - ] - error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs @id:$spec_id" - } - } - } - set argspecs $spec_merged - if {$is_opt} { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } else { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set arg_info $argname $argspecs - tcl::dict::set arg_checks $argname $argchecks - #review existence of -default overriding -optional - if {![tcl::dict::get $argspecs -optional] && ![tcl::dict::exists $argspecs -default]} { + } ;# end foreach {spec specval} argdef_values + + if {$is_opt} { - lappend opt_required $argname + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } else { - if {$argspace eq "leaders"} { - lappend leader_required $argname + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname } else { - lappend val_required $argname + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } } } - } - if {[tcl::dict::exists $argspecs -default]} { - if {$is_opt} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $argspecs -default] - } else { - if {$argspace eq "leaders"} { - tcl::dict::set leader_defaults $argname [tcl::dict::get $argspecs -default] + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $argspecs -default] + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } } } - } - } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + - if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { + if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { variable id_counter - set spec_id "autoid_[incr id_counter]" - } - - # REVIEW - #if {[llength $val_names] || $val_min > 0} { - # #some values are specified - # foreach leadername [lrange $leader_names 0 end] { - # if {[tcl::dict::get $arg_info $leadername -multiple]} { - # error "bad key -multiple on argument spec for leader '$leadername'. Last leader argument specification can be marked -multiple only when no values are specified" - # } - # } - #} else { + set DEF_definition_id "autoid_[incr id_counter]" + } + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW #no values specified - we can allow last leader to be multiple - foreach leadername [lrange $leader_names 0 end-1] { - if {[tcl::dict::get $arg_info $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple @id:$spec_id" + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" } } - #} - #confirm any valnames before last don't have -multiple key - foreach valname [lrange $val_names 0 end-1] { - if {[tcl::dict::get $arg_info $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple @id:$spec_id" + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - set leader_checks_defaults [tcl::dict::remove $leaderspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } set argdata_dict [tcl::dict::create\ - id $spec_id\ - arg_info $arg_info\ - arg_checks $arg_checks\ - leader_defaults $leader_defaults\ - leader_required $leader_required\ - leader_names $leader_names\ - leader_min $leader_min\ - leader_max $leader_max\ - leaderspec_defaults $leaderspec_defaults\ - leader_checks_defaults $leader_checks_defaults\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - opt_names $opt_names\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults $optspec_defaults\ - opt_checks_defaults $opt_checks_defaults\ - val_defaults $val_defaults\ - val_required $val_required\ - val_names $val_names\ - val_min $val_min\ - val_max $val_max\ - valspec_defaults $valspec_defaults\ - val_checks_defaults $val_checks_defaults\ - cmd_info $cmd_info\ - doc_info $doc_info\ - argdisplay_info $argdisplay_info\ - id_info $id_info\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + argdisplay_info $argdisplay_info\ + id_info $id_info\ + temp_F $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ ] + tcl::dict::set argdata_cache $cache_key $argdata_dict if {$is_dynamic} { #also cache resolved version tcl::dict::set argdata_cache $optionspecs $argdata_dict } - #tcl::dict::set argdefcache_by_id $spec_id $optionspecs - tcl::dict::set argdefcache_by_id $spec_id $args + #tcl::dict::set argdefcache_by_id $DEF_definition_id $optionspecs + tcl::dict::set argdefcache_by_id $DEF_definition_id $args #puts "xxx:$result" return $argdata_dict } - proc get_spec {id {patternlist *}} { + lappend PUNKARGS [list -dynamic 0 { + @id -id ::punk::args::get_spec + @cmd -name punk::args::get_definition -help\ + "" + id -type string -help\ + "identifer for punk::args defintion + This will usually be a fully-qualifed + path for a command name" + patternlist -type list -optional 1 -default * -help\ + "glob-style patterns for retrieving value or switch + definitions. If ommitted or passed an empty string, + the raw unresolved definition will be returned as + a list, including possible leading flags such as + -dynamic 0|1. + If specified as * - the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + " + override_dict -type dict -optional 1 -default "" -help\ + "unimplemented. + Will allow overriding or adding flags to a returned + definition line. + " + }] + #rename get_definition ??? + proc get_spec {id args} { + lassign $args patternlist override_dict + if {[llength $args] > 2} { + punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args] + return + } + if {[llength $override_dict] % 2 != 0} { + #malformed dict + punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args] + return + } + variable argdefcache_by_id set realid [real_id $id] if {$realid ne ""} { - if {$patternlist eq "*"} { - #todo? + if {$patternlist eq ""} { + #return the raw definition - possibly with unresolved dynamic parts return [tcl::dict::get $argdefcache_by_id $realid] } else { - set speclist [tcl::dict::get $argdefcache_by_id $realid] + set deflist [tcl::dict::get $argdefcache_by_id $realid] set result "" - set specdict [uplevel 1 [list ::punk::args::definition {*}$speclist]] - set arg_info [dict get $specdict arg_info] + set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]] + set arg_info [dict get $specdict ARG_INFO] foreach pat $patternlist { + if {[string match $pat @id]} { + #only a single id record can exist + append result \n "@id -id [dict get $specdict id]" + } + if {[string match $pat @cmd]} { + #only a single @cmd record can exist + #merged if multiple in original def (?) + append result \n "@cmd [dict get $specdict cmd_info]" + } + #todo @leaders, @opts, @values lines + #can be multiple of each. We need to preserve order and interleave + #with any matching arg_info results. + #requires storing more info in the internal spec dictionary set matches [dict keys $arg_info $pat] foreach m $matches { set def [dict get $arg_info $m] @@ -1250,9 +1607,9 @@ tcl::namespace::eval punk::args { set realid [real_id $id] if {$realid ne ""} { set speclist [tcl::dict::get $argdefcache_by_id $realid] - set specdict [definition {*}$speclist] - set arg_info [dict get $specdict arg_info] - set valnames [dict get $specdict val_names] + set specdict [define {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] set result "" if {$patternlist eq "*"} { foreach v $valnames { @@ -1280,7 +1637,7 @@ tcl::namespace::eval punk::args { proc get_def {id} { if {[id_exists $id]} { - return [definition {*}[get_spec $id]] + return [define {*}[get_spec $id]] } } proc is_dynamic {id} { @@ -1374,8 +1731,8 @@ tcl::namespace::eval punk::args { #puts -nonewline stderr . ;#debugging - see actual loads if {![catch { if {[info exists ${pkgns}::PUNKARGS]} { - foreach deflist [set ${pkgns}::PUNKARGS] { - namespace eval $pkgns [list punk::args::definition {*}$deflist] + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $pkgns [list punk::args::define {*}$definitionlist] } } if {[info exists ${pkgns}::PUNKARGS_aliases]} { @@ -1432,9 +1789,113 @@ tcl::namespace::eval punk::args { return $cmdinfo } + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::get_spec ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -choices {nocolour info error} + }] ] + #basic recursion blocker variable arg_error_isrunning 0 proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + if {[catch {package require punk::ansi}]} { proc punk::args::a {args} {} proc punk::args::a+ {args} {} @@ -1458,8 +1919,9 @@ tcl::namespace::eval punk::args { set badarg "" set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error + set scheme error dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return} $k] + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] switch -- $fullk { -badarg { set badarg $v @@ -1471,6 +1933,9 @@ tcl::namespace::eval punk::args { } set as_error $v } + -scheme { + set scheme $v + } -return { if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { set arg_error_isrunning 0 @@ -1484,6 +1949,68 @@ tcl::namespace::eval punk::args { } } } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. @@ -1510,13 +2037,13 @@ tcl::namespace::eval punk::args { append errmsg \n } else { if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)[a]" \n } else { append errmsg \n } } - set procname [Dict_getdef $spec_dict cmd_info -name ""] - set prochelp [Dict_getdef $spec_dict cmd_info -help ""] + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] set docurl [Dict_getdef $spec_dict doc_info -url ""] @@ -1531,18 +2058,18 @@ tcl::namespace::eval punk::args { set blank_header_col [list] - if {$procname ne ""} { + if {$cmdname ne ""} { lappend blank_header_col "" - set procname_display [a+ brightwhite]$procname[a] + set cmdname_display $CLR(cmdname)$cmdname[a] } else { - set procname_display "" + set cmdname_display "" } - if {$prochelp ne ""} { + if {$cmdhelp ne ""} { lappend blank_header_col "" - #set prochelp_display [a+ brightwhite]$prochelp[a] - set prochelp_display [textblock::ansibase_lines $prochelp [a+ white]] + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] } else { - set prochelp_display "" + set cmdhelp_display "" } if {$docurl ne ""} { lappend blank_header_col "" @@ -1550,11 +2077,25 @@ tcl::namespace::eval punk::args { } else { set docurl_display "" } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + if {$argdisplay_header ne ""} { lappend blank_header_col "" } if {$use_table} { - set t [textblock::class::table new [a+ brightyellow]Usage[a]] + set t [textblock::class::table new $CLR(title)Usage[a]] $t add_column -headers $blank_header_col -minwidth 3 $t add_column -headers $blank_header_col @@ -1573,19 +2114,19 @@ tcl::namespace::eval punk::args { } } set h 0 - if {$procname ne ""} { + if {$cmdname ne ""} { if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list PROC/METHOD: $procname_display] + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] } else { - lappend errlines "PROC/METHOD: $procname_display" + lappend errlines "COMMAND: $cmdname_display" } incr h } - if {$prochelp ne ""} { + if {$cmdhelp ne ""} { if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $prochelp_display] + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] } else { - lappend errlines "Description: $prochelp_display" + lappend errlines "Description: $cmdhelp_display" } incr h } @@ -1600,6 +2141,17 @@ tcl::namespace::eval punk::args { } incr h } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + if {$use_table} { if {$is_custom_argdisplay} { if {$argdisplay_header ne ""} { @@ -1632,11 +2184,13 @@ tcl::namespace::eval punk::args { set RST [a] #set A_DEFAULT [a+ brightwhite Brightgreen] set A_DEFAULT "" - set A_BADARG [a+ brightred] - set greencheck [a+ brightgreen]\u2713[a] ;#green tick - set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX [a+ green] ;#use a+ so colour off can apply - if {$A_PREFIX eq ""} { + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713[a] ;#green tick + set soloflag $CLR(solo)\u2690[a] ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead set A_PREFIX [a+ underline] set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space } else { @@ -1645,14 +2199,14 @@ tcl::namespace::eval punk::args { set opt_names [list] set opt_names_display [list] - if {[llength [dict get $spec_dict opt_names]]} { + 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 trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] set idents [dict get [$trie shortest_idents ""] scanned] #todo - check opt_prefixdeny $trie destroy - foreach c [dict get $spec_dict opt_names] { + foreach c [dict get $spec_dict OPT_NAMES] { set id [dict get $idents $c] #REVIEW if {$id eq $c} { @@ -1668,12 +2222,12 @@ tcl::namespace::eval punk::args { lappend opt_names $c } } else { - set opt_names [dict get $spec_dict opt_names] + set opt_names [dict get $spec_dict OPT_NAMES] set opt_names_display $opt_names } } - set leading_val_names [dict get $spec_dict leader_names] - set trailing_val_names [dict get $spec_dict val_names] + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { # if {![string match -* $argname]} { @@ -1695,7 +2249,7 @@ tcl::namespace::eval punk::args { lassign $argumentset argnames_display argnames foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict arg_info $arg] + set arginfo [dict get $spec_dict ARG_INFO $arg] if {[dict exists $arginfo -default]} { set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { @@ -1707,6 +2261,13 @@ tcl::namespace::eval punk::args { set choicegroups [Dict_getdef $arginfo -choicegroups {}] set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } if {[dict exists $choicegroups ""]} { dict lappend choicegroups "" {*}$choices } else { @@ -1827,12 +2388,11 @@ tcl::namespace::eval punk::args { #TODO -title directly in list_as_table set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] lappend choicetable_objects $choicetableobj - $choicetableobj configure -title [a+ cyan]$groupname + $choicetableobj configure -title $CLR(groupname)$groupname #append help \n[textblock::join -- " " [$choicetableobj print]] } else { if {$groupname ne ""} { - #bold as well as brightcolour in case colour off. - append help \n \n "[a+ brightyellow bold]Group: $groupname[a]" + append help \n \n "$CLR(groupname)Group: $groupname[a]" } else { append help \n } @@ -1846,15 +2406,15 @@ tcl::namespace::eval punk::args { if {$usetable} { #these will be displayed after all table entries if {$groupname eq ""} { - dict set choicetable_footers "" " [a+ red](no choices defined for main group)[a]" + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)[a]" } else { - dict set choicetable_footers $groupname " [a+ red](no choices defined for group $groupname)[a]" + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)[a]" } } else { if {$groupname eq ""} { - append help \n " " [a+ red](no choices defined)[a] + append help \n " " $CLR(errormsg)(no choices defined)[a] } else { - append help \n " " [a+ red](no choices defined for group $groupname)[a] + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)[a] } } } @@ -1896,13 +2456,16 @@ tcl::namespace::eval punk::args { } } } - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - set argshow "?${argshow}?" + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } } set typeshow [dict get $arginfo -type] if {$typeshow eq "none"} { @@ -1936,7 +2499,13 @@ tcl::namespace::eval punk::args { } ;#end is_custom_argdisplay if {$use_table} { - $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + $t configure -maxwidth 80 ;#review if {$returntype ne "tableobject"} { append errmsg [$t print] @@ -1976,7 +2545,7 @@ tcl::namespace::eval punk::args { } - lappend PUNKARGS [list { + lappend PUNKARGS [list -dynamic 1 { @id -id ::punk::args::usage @cmd -name punk::args::usage -help\ "Return usage information for a command. @@ -1989,6 +2558,7 @@ tcl::namespace::eval punk::args { mechanism and call this as necessary. " -return -default table -choices {string table tableobject} + } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} { @values -min 0 -max 1 id -help\ @@ -1998,11 +2568,12 @@ tcl::namespace::eval punk::args { proc usage {args} { lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received set id [dict get $values id] - set speclist [get_spec $id] - if {[llength $speclist] == 0} { + set definitionlist [get_spec $id] + if {[llength $definitionlist] == 0} { error "punk::args::usage - no such id: $id" } - arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] {*}$opts -aserror 0 + #by placing scheme before the supplied args - it can be overridden + arg_error "" [uplevel 1 [list punk::args::define {*}$definitionlist]] -scheme punk_info {*}$opts -aserror 0 } lappend PUNKARGS [list { @@ -2010,16 +2581,150 @@ tcl::namespace::eval punk::args { @cmd -name punk::args::get_by_id @values -min 1 id - arglist -default "" -type list -help\ + arglist -type list -help\ "list containing arguments to be parsed as per the argument specification identified by the supplied id." }] - proc get_by_id {id {arglist ""}} { - set speclist [punk::args::get_spec $id] - if {[llength $speclist] == 0} { + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::get_spec $id] + if {[llength $definitionlist] == 0} { error "punk::args::get_by_id - no such id: $id" } - return [uplevel 1 [list ::punk::args::get_dict {*}$speclist $arglist]] + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing + record that has been created with ::punk::args::define. + In the 'withdef' form - the definition is created on the + first call and cached thereafter. + + form1: parse ?-flag val?... -- $arglist withid $id + form2: parse ?-flag val?... -- $arglist withdef $def ?$def? + see punk::args::define" + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries. + " + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard minimal} + @values -min 3 + sep -optional 0 -choices "--" + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + set split [lsearch -exact $args --] ;#first -- + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. End of opts marker -- is required even if no options are present." + } + set opts [lrange $args 0 $split-1] ;#repeated flags will override earlier. That's ok here. + set arglist [lindex $args $split+1] + set tailtype [lindex $args $split+2] + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $args $split+3 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $split+3] + return "parse [llength $arglist] args withid $id, options:$opts" + } + withdef { + if {[llength [lrange $args $split+3 end]] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO } #todo? - a version of get_dict that directly supports punk::lib::tstr templating @@ -2031,6 +2736,15 @@ tcl::namespace::eval punk::args { #only supports -flag val pairs, not solo options #If an option is supplied multiple times - only the last value is used. proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + #*** !doctools #[call [fun get_dict] [arg optionspecs] [arg rawargs]] #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values @@ -2065,54 +2779,26 @@ tcl::namespace::eval punk::args { # @values -multiple 1 #} $args - #if {[llength $args] == 0} { - # set rawargs [list] - #} elseif {[llength $args] ==1} { - # set rawargs [lindex $args 0] ;#default tcl style - #} else { - # #todo - can we support tk style vals before flags? - # #the aim is to allow a single call to validate standard leading proc positional args along with the $args val which may have flags in tk or tcl order - # #by allowing all to be in a single call - we could use a -help (or similar erroring call) to trigger the spec-parsing from a wrapper function. - # #this would be important in the case where the function to be wrapped has never been called - but the wrapper needs info about the downstream options - # #we would like to avoid the ugliness of trying to parse a proc body to scrape the specification. - # #we may still need to do a basic scan of the proc body to determine if it at least contains the string punk::args::get_dict - but that is slightly less odious. - # error "unsupported number of arguments for punk::args::get_dict" - # set inopt 0 - # set k "" - # set i 0 - # foreach a $args { - # switch -- $f { - # -opts { - - # } - # -vals { - - # } - # -optvals { - # #tk style - - # } - # -valopts { - # #tcl style - # set rawargs [lindex $args $i+1] - # incr i - # } - # default { - - # } - # } - # incr i - # } - #} set is_dynamic 0 if {[lindex $args 0] eq "-dynamic"} { set is_dynamic [lindex $args 1] } set rawargs [lindex $args end] ;# args values to be parsed - set def_args [lrange $args 0 end-1] - set argspecs [uplevel 1 [list ::punk::args::definition {*}$def_args]] + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::define {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + #puts "-arg_info->$arg_info" set flagsreceived [list] ;#for checking if required flags satisfied #secondary purpose: @@ -2128,31 +2814,31 @@ tcl::namespace::eval punk::args { set opts $opt_defaults set pre_values {} - set argnames [tcl::dict::keys $arg_info] + set argnames [tcl::dict::keys $ARG_INFO] set optnames [lsearch -all -inline $argnames -*] set ridx 0 set rawargs_copy $rawargs set leader_posn_name "" set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) set is_multiple 0 ;#last leader may be multi - if {$leader_max != 0} { + if {$LEADER_MAX != 0} { foreach r $rawargs_copy { - if {$leader_max ne "" && $leader_max != -1 && $ridx > $leader_max-1} { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { break } - if {$ridx == [llength $leader_names]-1} { + if {$ridx == [llength $LEADER_NAMES]-1} { #at last named leader - set leader_posn_name [lindex $leader_names $ridx] - if {[dict exists $arg_info $leader_posn_name -multiple] && [dict get $arg_info $leader_posn_name -multiple]} { + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { set is_multiple 1 } - } elseif {$ridx > [llength $leader_names]-1} { + } elseif {$ridx > [llength $LEADER_NAMES]-1} { #beyond names - retain name if -multiple was true if {!$is_multiple} { set leader_posn_name "" } } else { - set leader_posn_name [lindex $leader_names $ridx] ;#may return empty string + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string } if {$r eq "--"} { #review end of opts marker: '--' can't be a leader (but can be a value) @@ -2181,7 +2867,7 @@ tcl::namespace::eval punk::args { #for each branch - break or lappend if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $leader_required} { + if {$leader_posn_name ni $LEADER_REQUIRED} { #optional leader #most adhoc arg processing will allocate based on number of args rather than matching choice values first @@ -2220,11 +2906,11 @@ tcl::namespace::eval punk::args { } } else { #unnamed leader - if {$leader_min ne "" } { - if {$ridx > $leader_min} { + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { break } else { - #haven't reached leader_min + #haven't reached LEADER_MIN lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } @@ -2234,16 +2920,24 @@ tcl::namespace::eval punk::args { } incr ridx - } + } ;# end foreach r $rawargs_copy } - if {$leader_min eq ""} { - set leader_min 0 + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN } - if {$leader_max eq ""} { - set leader_max -1 + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX } - #assert leader_max leader_min are numeric + #assert leadermax leadermin are numeric #assert - rawargs has been reduced by leading positionals set leaders [list] @@ -2251,7 +2945,7 @@ tcl::namespace::eval punk::args { set post_values {} #val_min, val_max #puts stderr "rawargs: $rawargs" - #puts stderr "arg_info: $arg_info" + #puts stderr "argstate: $argstate" if {[lsearch $rawargs -*] >= 0} { #at least contains flaglike things.. set maxidx [expr {[llength $rawargs] -1}] @@ -2298,9 +2992,9 @@ tcl::namespace::eval punk::args { } break } else { - set fullopt [tcl::prefix match -error "" $opt_names $a] + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] if {$fullopt ne ""} { - if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { #non-solo #check if it was actually a value that looked like a flag if {$i == $maxidx} { @@ -2312,7 +3006,7 @@ tcl::namespace::eval punk::args { } set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $argstate $fullopt -multiple]} { #don't lappend to default - we need to replace if there is a default if {$fullopt ni $flagsreceived} { tcl::dict::set opts $fullopt [list $flagval] @@ -2329,7 +3023,7 @@ tcl::namespace::eval punk::args { } } else { #solo - if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $argstate $fullopt -multiple]} { if {$fullopt ni $flagsreceived} { #override any default - don't lappend to it tcl::dict::set opts $fullopt 1 @@ -2359,10 +3053,10 @@ tcl::namespace::eval punk::args { if {$opt_any} { set newval [lindex $rawargs $i+1] #opt was unspecified but is allowed due to @opts -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::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { tcl::dict::lappend opts $a $newval } else { tcl::dict::set opts $a $newval @@ -2373,7 +3067,7 @@ tcl::namespace::eval punk::args { 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::get $argstate $a -multiple]} { if {![tcl::dict::exists $opts $a]} { tcl::dict::set opts $a 1 } else { @@ -2386,8 +3080,8 @@ tcl::namespace::eval punk::args { } lappend flagsreceived $a ;#adhoc flag as supplied } else { - if {[llength $opt_names]} { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" + if {[llength $OPT_NAMES]} { + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" } else { set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" } @@ -2419,15 +3113,15 @@ tcl::namespace::eval punk::args { set ldridx 0 set in_multiple "" set leadernames_received [list] - set leaders_dict $leader_defaults + set leaders_dict $LEADER_DEFAULTS set num_leaders [llength $leaders] - foreach leadername $leader_names ldr $leaders { + foreach leadername $LEADER_NAMES ldr $leaders { if {$ldridx+1 > $num_leaders} { break } if {$leadername ne ""} { - if {[tcl::dict::get $arg_info $leadername -multiple]} { - if {[tcl::dict::exists $leader_defaults $leadername]} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list } else { tcl::dict::lappend leaders_dict $leadername $ldr @@ -2443,8 +3137,8 @@ tcl::namespace::eval punk::args { lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) } else { tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set arg_info $positionalidx $leaderspec_defaults - tcl::dict::set arg_checks $positionalidx $leader_checks_defaults + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS lappend leadernames_received $positionalidx } } @@ -2457,12 +3151,12 @@ tcl::namespace::eval punk::args { set valnames_received [list] set values_dict $val_defaults set num_values [llength $values] - foreach valname $val_names val $values { + foreach valname $VAL_NAMES val $values { if {$validx+1 > $num_values} { break } if {$valname ne ""} { - if {[tcl::dict::get $arg_info $valname -multiple]} { + if {[tcl::dict::get $argstate $valname -multiple]} { if {[tcl::dict::exists $val_defaults $valname]} { #current stored val equals defined default - don't include default in the list we build up tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list @@ -2481,8 +3175,8 @@ tcl::namespace::eval punk::args { lappend valnames_received $in_multiple } else { tcl::dict::set values_dict $positionalidx $val - tcl::dict::set arg_info $positionalidx $valspec_defaults - tcl::dict::set arg_checks $positionalidx $val_checks_defaults + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS lappend valnames_received $positionalidx } } @@ -2490,17 +3184,17 @@ tcl::namespace::eval punk::args { incr positionalidx } - if {$leader_max == -1} { + if {$leadermax == -1} { #only check min - if {$num_leaders < $leader_min} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leader_min" $argspecs + if {$num_leaders < $leadermin} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs } } else { - if {$num_leaders < $leader_min || $num_leaders > $leader_max} { - if {$leader_min == $leader_max} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leader_min" $argspecs + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs } else { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leader_min and $leader_max inclusive" $argspecs + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs } } } @@ -2541,7 +3235,7 @@ tcl::namespace::eval punk::args { # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $leader_required $leadernames_received]]]} { + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs } if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { @@ -2560,9 +3254,9 @@ tcl::namespace::eval punk::args { set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash #puts "---opts_and_values:$opts_and_values" - #puts "---arg_info:$arg_info" + #puts "---argstate:$argstate" tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $arg_info $argname] + set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] set thisarg_checks [tcl::dict::get $arg_checks $argname] set is_multiple [tcl::dict::get $thisarg -multiple] @@ -3471,10 +4165,10 @@ tcl::namespace::eval punk::args::lib { #for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. #arguably it may be more processor-cache-efficient to do together like this anyway. -#can't do this - as there is circular dependency with punk::lib +#can't do this here? - as there is circular dependency with punk::lib #tcl::namespace::eval punk::args { # foreach deflist $PUNKARGS { -# punk::args::definition {*}$deflist +# punk::args::define {*}$deflist # } # set PUNKARGS "" #} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm index 3024053b..8cb06b1f 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm @@ -1246,6 +1246,10 @@ tcl::namespace::eval punk::char { return [charset_dict "Box Drawing"] } + proc char_hex {char} { + return [format %08x [scan $char %c]] + } + proc char_info_hex {hex args} { set hex [tcl::string::map [list _ ""] $hex] if {[tcl::string::is xdigit -strict $hex]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index d2c08e8b..74365afa 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -1186,7 +1186,7 @@ namespace eval punk::console { #todo - change -inoutchannels to -terminalobject with prebuilt default - punk::args::definition { + punk::args::define { @id -id ::punk::console::cell_size -inoutchannels -default {stdin stdout} -type list @values -min 0 -max 1 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm index 6de20bff..1f02859b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -1251,7 +1251,7 @@ namespace eval punk::fileline { #[para] Core API functions for punk::fileline #[list_begin definitions] - punk::args::definition { + punk::args::define { @id -id ::punk::fileline::get_textinfo @cmd -name punk::fileline::get_textinfo -help\ "return: textinfo object instance" diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index f427f29f..b5539021 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -26,7 +26,7 @@ package require punk::lib namespace eval punk::mix::commandset::loadedlib { namespace export * #search automatically wrapped in * * - can contain inner * ? globs - punk::args::definition { + punk::args::define { @id -id ::punk::mix::commandset::loadedlib::search @cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" -return -type string -default table -choices {table tableobject list lines} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index 2079eb8c..41206d0c 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -141,7 +141,7 @@ namespace eval punk::mix::commandset::module { set moduletypes [punk::mix::cli::lib::module_types] - punk::args::definition [subst { + punk::args::define [subst { @id -id ::punk::mix::commandset::module::new @cmd -name "punk::mix::commandset::module::new" -help\ "Create a new module file in the appropriate folder within src/modules. diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 3f5f3a71..5d601b3a 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -636,7 +636,7 @@ tcl::namespace::eval punk::nav::fs { # c:/repo/jn/punk/../../blah #dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold # dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream - punk::args::definition { + punk::args::define { @id -id ::punk::nav::fs::dirfiles -stripbase -default 1 -type boolean -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" @@ -992,7 +992,7 @@ tcl::namespace::eval punk::nav::fs { return [dict merge $listing $updated] } - punk::args::definition { + punk::args::define { @id -id ::punk::nav::fs::dirfiles_dict_as_lines -stripbase -default 0 -type boolean -formatsizes -default 1 -type boolean diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index f8a1e939..6235224a 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -1893,7 +1893,31 @@ tcl::namespace::eval punk::ns { } } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} $vline" set idauto "(autodef)$origin" - set argspec [punk::lib::tstr -return string { + set argdef [punk::lib::tstr -return string { @id -id ${$idauto} @cmd -name "Object: ${$origin}" -help\ "Instance of class: ${$class} (info autogenerated)" @values -min 1 }] - append argspec \n $vline - punk::args::definition $argspec + append argdef \n $vline + punk::args::define $argdef return [punk::args::usage {*}$opts $idauto] } privateObject { @@ -2457,7 +2502,8 @@ tcl::namespace::eval punk::ns { set match [tcl::prefix::match $subcommands [lindex $queryargs 0]] if {$match in $subcommands} { set subcmd [dict get $subcommand_dict $match] - return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + return [arginfo {*}$opts {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") } } @@ -2491,15 +2537,15 @@ tcl::namespace::eval punk::ns { set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] set autoid "(autodef)$origin" - set argspec [punk::lib::tstr -return string { + set argdef [punk::lib::tstr -return string { @id -id ${$autoid} @cmd -help\ "(autogenerated) ensemble: ${$origin}" @values -min 1 }] - append argspec \n $vline - punk::args::definition $argspec + append argdef \n $vline + punk::args::define $argdef return [punk::args::usage {*}$opts $autoid] } @@ -2918,7 +2964,7 @@ tcl::namespace::eval punk::ns { } interp alias "" use "" punk::ns::pkguse - punk::args::definition { + punk::args::define { @id -id ::punk::ns::nsimport_noclobber @cmd -name punk::ns::nsimport_noclobber -help\ "Import exported commands from a namespace into either the current namespace, diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index 65ede7c8..ede3e18b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -644,7 +644,7 @@ namespace eval punk::path { return $ismatch } - punk::args::definition { + punk::args::define { @id -id ::punk::path::treefilenames -directory -type directory -help\ "folder in which to begin recursive scan for files." diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index 98bc04ef..063a13c0 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -65,6 +65,22 @@ namespace eval punk::repo { variable PUNKARGS variable PUNKARGS_aliases + variable cached_command_paths + set cached_command_paths [dict create] + #anticipating possible removal of buggy caching from auto_execok + #mentioned in: https://core.tcl-lang.org/tcl/tktview/4dc35e0c0c + #this would leave the application to decide what it wants to cache in that regard. + proc Cached_auto_execok {name} { + return [auto_execok $name] + #variable cached_command_paths + #if {[dict exists $cached_command_paths $name]} { + # return [dict get $cached_command_paths $name] + #} + #set resolved [auto_execok $name] + #dict set cached_command_paths $name $resolved + #return $resolved + } + proc get_fossil_usage {} { set allcmds [runout -n fossil help -a] set mainhelp [runout -n fossil help] @@ -197,7 +213,7 @@ namespace eval punk::repo { #emit warning whether or not multiple fossil repos puts stdout [dict get $repostate warnings] } - set fossil_prog [auto_execok fossil] + set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog ne ""} { {*}$fossil_prog {*}$args } else { @@ -222,7 +238,10 @@ namespace eval punk::repo { #uppercase FOSSIL to bypass fossil as alias to fossil_proxy + #only necessary on unix? + #Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway proc establish_FOSSIL {args} { + #review if {![info exists ::auto_execs(FOSSIL)]} { set ::auto_execs(FOSSIL) [auto_execok fossil] ;#may fail in safe interp } @@ -499,7 +518,7 @@ namespace eval punk::repo { #For this reason we will store 'unchanged' records for both git and fossil so that the combined dict should represent all files in the revision if {$rt eq "fossil"} { dict set resultdict repotype fossil - set fossil_cmd [auto_execok fossil] + set fossil_cmd [Cached_auto_execok fossil] if {$fossil_cmd eq ""} { error "workingdir_state error: fossil executable doesn't seem to be available" } @@ -598,7 +617,7 @@ namespace eval punk::repo { break } elseif {$rt eq "git"} { dict set resultdict repotype git - set git_cmd [auto_execok git] + set git_cmd [Cached_auto_execok git] # -uno = suppress ? lines. # -b = show ranch and tracking info #our basic parsing/grepping assumes --porcelain=2 @@ -988,7 +1007,7 @@ namespace eval punk::repo { } proc fossil_get_repository_file {{path {}}} { if {$path eq {}} { set path [pwd] } - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set fossilinfo [::exec {*}$fossilcmd info] @@ -1073,7 +1092,7 @@ namespace eval punk::repo { set startdir $opt_parentfolder - set fossil_prog [auto_execok fossil] + set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog eq ""} { puts stderr "Fossil not found. Please install fossil" return @@ -1319,7 +1338,7 @@ namespace eval punk::repo { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[Cached_auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } @@ -1332,7 +1351,7 @@ namespace eval punk::repo { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[Cached_auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } @@ -1343,7 +1362,7 @@ namespace eval punk::repo { proc fossil_revision {{path {}}} { if {$path eq {}} { set path [pwd] } # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set info [::exec {*}$fossilcmd info] @@ -1357,7 +1376,7 @@ namespace eval punk::repo { proc fossil_remote {{path {}}} { if {$path eq {}} { set path [pwd] } # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set info [::exec {*}$fossilcmd remote ls] @@ -1423,7 +1442,7 @@ namespace eval punk::repo { set original_cwd [pwd] #attempt2 - let fossil do it for us - hopefully based on current folder if {$path eq {}} {set path [pwd]} - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {![llength $fossilcmd]} { set fossil_ok 0 } else { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm index dcc023ec..a3d5b967 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm @@ -8367,7 +8367,7 @@ tcl::namespace::eval textblock { foreach tline $tlines { if {[tcl::string::first $FSUB $tline] >= 0} { set content_line [lindex $clines $contentindex] - if {[tcl::string::first $R $content_line] == 0} { + if {[tcl::string::first $R [string range $content_line 0 10]] == 0} { set content_line [tcl::string::range $content_line $rlen end] } #make sure to replay opt_ansibase to the right of the replacement diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm new file mode 100644 index 00000000..32450e55 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -0,0 +1,8567 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix 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. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application textblock 0.1.3 +# Meta platform tcl +# Meta license +# @@ Meta End + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_textblock 0 0.1.3] +#[copyright "2024"] +#[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 ansi text layout colour table frame console terminal] +#[description] +#[para] Ansi-aware terminal textblock manipulation + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of textblock +#[subsection Concepts] +#[para] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by textblock +#[list_begin itemized] + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] +#[item] [package {punk::char}] +#[item] [package {punk::ansi}] +#[item] [package {punk::lib}] +#[item] [package {overtype}] +#[item] [package {term::ansi::code::macros}] +#[item] [package {textutil}] + +## Requirements +package require Tcl 8.6- +package require punk::args +package require punk::char +package require punk::ansi +package require punk::lib +catch {package require patternpunk} +package require overtype + +#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. +if {[catch { + package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? +} errM]} { + #catch this too in case stderr not available + catch { + puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM" + } +} +package require textutil + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval textblock { + #review - what about ansi off in punk::console? + tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ + tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock + + #NOTE sha1, although computationally more intensive, tends to be faster than md5 on modern cpus + #(more likely to be optimised for modern cpu features?) + #(This speed improvement may not apply for short strings) + + variable use_hash ;#framecache + set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display + #if {![catch {package require sha1}]} { + # set use_hash sha1 + #} elseif {![catch {package require md5}]} { + # set use_hash md5 + #} else { + # set use_hash none + #} + + proc use_hash {args} { + set choices [list none] + set unavailable [list] + set pkgs [package names] + if {"md5" in $pkgs} { + lappend choices md5 + } else { + lappend unavailable md5 + } + if {"sha1" in $pkgs} { + lappend choices sha1 + } else { + lappend unavailable sha1 + } + set choicemsg "" + if {[llength $unavailable]} { + set choicemsg " (unavailable packages: $unavailable)" + } + set argd [punk::args::get_dict [tstr -return string { + @id -id ::textblock::use_hash + @cmd -name "textblock::use_hash" -help\ + "Hashing algorithm to use for framecache lookup. + 'none' may be slightly faster but less compact + when viewing textblock::framecache" + @values -min 0 -max 1 + hash_algorithm -choices {${$choices}} -optional 1 -help\ + "algorithm choice ${$choicemsg}" + }] $args] + variable use_hash + if {![dict exists $argd received hash_algorithm]} { + return $use_hash + } + set use_hash [dict get $argd values hash_algorithm] + } + tcl::namespace::eval class { + variable opts_table_defaults + set opts_table_defaults [tcl::dict::create\ + -title ""\ + -titlealign "left"\ + -titletransparent 0\ + -frametype "light"\ + -frametype_header ""\ + -ansibase_header ""\ + -ansibase_body ""\ + -ansibase_footer ""\ + -ansiborder_header ""\ + -ansiborder_body ""\ + -ansiborder_footer ""\ + -ansireset "\uFFeF"\ + -framelimits_header "vll vlr hlb hlt tlc trc blc brc"\ + -frametype_body ""\ + -framelimits_body "vll vlr hlb hlt tlc trc blc brc"\ + -framemap_body [list\ + topleft {} topinner {} topright {} topsolo {}\ + middleleft {} middleinner {} middleright {} middlesolo {}\ + bottomleft {} bottominner {} bottomright {} bottomsolo {}\ + onlyleft {} onlyinner {} onlyright {} onlysolo {}\ + ]\ + -framemap_header [list\ + topleft {} topinner {} topright {} topsolo {}\ + middleleft {} middleinner {} middleright {} middlesolo {}\ + bottomleft {} bottominner {} bottomright {} bottomsolo {}\ + onlyleft {} onlyinner {} onlyright {} onlysolo {}\ + ]\ + -show_edge 1\ + -show_seps 1\ + -show_hseps ""\ + -show_vseps ""\ + -show_header ""\ + -show_footer ""\ + -minwidth ""\ + -maxwidth ""\ + ] + variable opts_column_defaults + set opts_column_defaults [tcl::dict::create\ + -headers [list]\ + -header_colspans [list]\ + -footers [list]\ + -defaultvalue ""\ + -ansibase ""\ + -ansireset "\uFFEF"\ + -minwidth ""\ + -maxwidth ""\ + -blockalign centre\ + -textalign left\ + ] + #initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only + + + + #for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns) + #ie only vll,blc,hlb used for cells except top row and right column + #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) + #right cells use 'U' shape (vll,blc,hlb,brc,vlr) + #e.g for 4x4 + # C C C O + # L L L U + # L L L U + #anti-clockwise elements + set C [list hlt tlc vll blc hlb] + set O [list trc hlt tlc vll blc hlb brc vlr] + set L [list vll blc hlb] + set U [list vll blc hlb brc vlr] + set tops [list trc hlt tlc] + set lefts [list tlc vll blc] + set bottoms [list blc hlb brc] + set rights [list trc brc vlr] + + variable table_edge_parts + set table_edge_parts [tcl::dict::create\ + topleft [struct::set intersect $C [concat $tops $lefts]]\ + 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]\ + middleinner [list]\ + middleright [struct::set intersect $U $rights]\ + middlesolo [struct::set intersect $U [concat $lefts $rights]]\ + bottomleft [struct::set intersect $L [concat $lefts $bottoms]]\ + bottominner [struct::set intersect $L $bottoms]\ + bottomright [struct::set intersect $U [concat $bottoms $rights]]\ + bottomsolo [struct::set intersect $U [concat $lefts $bottoms $rights]]\ + onlyleft [struct::set intersect $C [concat $tops $lefts $bottoms]]\ + onlyinner [struct::set intersect $C [concat $tops $bottoms]]\ + onlyright [struct::set intersect $O [concat $tops $bottoms $rights]]\ + onlysolo [struct::set intersect $O [concat $tops $lefts $bottoms $rights]]\ + ] + + #for header rows - we don't consider the bottom border as part of the edge - even if table body has no rows + #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 [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 [list {*}$lefts {*}$rights]]\ + bottomleft [struct::set intersect $L $lefts]\ + bottominner [list]\ + bottomright [struct::set intersect $U $rights]\ + 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 [list {*}$tops {*}$rights]]\ + onlysolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ + ] + variable table_hseps + set table_hseps [tcl::dict::create\ + topleft [list blc hlb]\ + topinner [list blc hlb]\ + topright [list blc hlb brc]\ + topsolo [list blc hlb brc]\ + middleleft [list blc hlb]\ + middleinner [list blc hlb]\ + middleright [list blc hlb brc]\ + middlesolo [list blc hlb brc]\ + bottomleft [list]\ + bottominner [list]\ + bottomright [list]\ + bottomsolo [list]\ + onlyleft [list]\ + onlyinner [list]\ + onlyright [list]\ + onlysolo [list]\ + ] + variable table_vseps + set table_vseps [tcl::dict::create\ + topleft [list]\ + topinner [list vll tlc blc]\ + topright [list vll tlc blc]\ + topsolo [list]\ + middleleft [list]\ + middleinner [list vll tlc blc]\ + middleright [list vll tlc blc]\ + middlesolo [list]\ + bottomleft [list]\ + bottominner [list vll tlc blc]\ + bottomright [list vll tlc blc]\ + bottomsolo [list]\ + onlyleft [list]\ + onlyinner [list vll tlc blc]\ + onlyright [list vll tlc blc]\ + onlysolo [list]\ + ] + + #ensembles seem to be not compiled in safe interp + #https://core.tcl-lang.org/tcl/tktview/1095bf7f75 + #as we want textblock to be usable in safe interps - use tcl::dict::for as a partial workaround + #This at least means the script argument, especially switch statements can get compiled. + #It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp. + + #e.g $t configure -framemap_body [table_edge_map " "] + + # -- --- --- --- --- + #unused? + proc table_edge_map {char} { + variable table_edge_parts + set map [list] + tcl::dict::for {celltype parts} $table_edge_parts { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + proc table_sep_map {char} { + variable table_hseps + set map [list] + tcl::dict::for {celltype parts} $table_hseps { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + proc header_edge_map {char} { + variable header_edge_parts + set map [list] + tcl::dict::for {celltype parts} $header_edge_parts { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + # -- --- --- --- --- + + if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} { + #*** !doctools + #[subsection {Namespace textblock::class}] + #[para] class definitions + #[list_begin itemized] [comment {- textblock::class groupings -}] + # [item] + # [para] [emph {handler_classes}] + # [list_begin enumerated] + + #this makes new table objects a little faster when multiple opts specified as well as to configure + #as tables are a heavyweight thing, but handy to nest sometimes - we'll take what we can get + set topt_keys [tcl::dict::keys $::textblock::class::opts_table_defaults] + set switch_keys_valid_topts [punk::lib::lmapflat v $topt_keys {list $v -}] + set switch_keys_valid_topts [lrange $switch_keys_valid_topts 0 end-1] ;#remove last dash + + set copt_keys [tcl::dict::keys $::textblock::class::opts_column_defaults] + set switch_keys_valid_copts [punk::lib::lmapflat v $copt_keys {list $v -}] + 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. + + variable o_columndefs + variable o_columndata + variable o_columnstates + variable o_headerdefs + variable o_headerstates + + variable o_rowdefs + variable o_rowstates + + variable o_opts_table_defaults + variable o_opts_header_defaults ;# header data mostly stored in o_columndefs + variable o_opts_column_defaults + variable o_opts_row_defaults + variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap) + variable o_calculated_column_widths + variable o_column_width_algorithm + + + 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 + + + if {[llength $args] == 1} { + set args [list -title [lindex $args 0]] + } + if {[llength $args] %2 !=0} { + error "[tcl::namespace::current]::table constructor - unexpected argument count. Require single value being title, or name value pairs" + } + + set o_opts_table $o_opts_table_defaults + set o_opts_table_effective $o_opts_table_defaults + + ##todo - test with punk::lib::show_jump_tables - how? + foreach {k v} $args { + switch -- $k { + %topt_switchkeys% { + tcl::dict::set o_opts_table $k $v + } + default { + error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + } + + #foreach {k v} $args { + # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. + # if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { + # error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + # } + #} + #set o_opts_table [tcl::dict::merge $o_opts_table_defaults $args] + #my configure {*}[tcl::dict::merge $o_opts_table_defaults $args] + + set o_columndefs [tcl::dict::create] + set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row + set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly + set o_headerdefs [tcl::dict::create] ;#by header-row + set o_headerstates [tcl::dict::create] + set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight + set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data + + set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices. + set o_calculated_column_widths [list] + set o_column_width_algorithm "span" + set o_opts_header_defaults [tcl::dict::create\ + -colspans {}\ + -values {}\ + -ansibase {}\ + -ansireset "\x1b\[m"\ + -minheight 1\ + -maxheight ""\ + ] + my configure {*}$o_opts_table + } + + method width_algorithm {{alg ""}} { + if {$alg eq ""} { + return $o_column_width_algorithm + } + if {$alg ne $o_column_width_algorithm} { + #invalidate cached widths + set o_calculated_column_widths [list] + } + set o_column_width_algorithm $alg + } + method Get_seps {} { + set requested_seps [tcl::dict::get $o_opts_table -show_seps] + set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] + set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] + set seps $requested_seps + set seps_h $requested_seps_h + set seps_v $requested_seps_v + if {$requested_seps eq ""} { + if {$requested_seps_h eq ""} { + set seps_h 1 + } + if {$requested_seps_v eq ""} { + set seps_v 1 + } + } else { + if {$requested_seps_h eq ""} { + set seps_h $seps + } + if {$requested_seps_v eq ""} { + set seps_v $seps + } + } + return [tcl::dict::create horizontal $seps_h vertical $seps_v] + } + method Get_frametypes {} { + set requested_ft [tcl::dict::get $o_opts_table -frametype] + set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] + set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] + set ft $requested_ft + set ft_header $requested_ft_header + set ft_body $requested_ft_body + switch -- $requested_ft { + light { + if {$requested_ft_header eq ""} { + set ft_header heavy + } + if {$requested_ft_body eq ""} { + 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 + } + if {$requested_ft_body eq ""} { + set ft_body $requested_ft + } + } + } + return [tcl::dict::create header $ft_header body $ft_body] + } + method Set_effective_framelimits {} { + upvar ::textblock::class::opts_table_defaults tdefaults + set default_blims [tcl::dict::get $tdefaults -framelimits_body] + set default_hlims [tcl::dict::get $tdefaults -framelimits_header] + set eff_blims [tcl::dict::get $o_opts_table_effective -framelimits_body] + set eff_hlims [tcl::dict::get $o_opts_table_effective -framelimits_header] + + set requested_blims [tcl::dict::get $o_opts_table -framelimits_body] + set requested_hlims [tcl::dict::get $o_opts_table -framelimits_header] + set blims $eff_blims + set hlims $eff_hlims + switch -- $requested_blims { + "default" { + set blims $default_blims + } + default { + #set blims $requested_blims + set blims [list] + foreach lim $requested_blims { + switch -- $lim { + hl { + lappend blims hlt hlb + } + vl { + lappend blims vll vlr + } + default { + lappend blims $lim + } + } + } + set blims [lsort -unique $blims] + } + } + tcl::dict::set o_opts_table_effective -framelimits_body $blims + switch -- $requested_hlims { + "default" { + set hlims $default_hlims + } + default { + #set hlims $requested_hlims + set hlims [list] + foreach lim $requested_hlims { + switch -- $lim { + hl { + lappend hlims hlt hlb + } + vl { + lappend hlims vll vlr + } + default { + lappend hlims $lim + } + } + } + set hlims [lsort -unique $hlims] + } + } + tcl::dict::set o_opts_table_effective -framelimits_header $hlims + 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 + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [list %topt_keys%]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_opts_table $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { + tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "[tcl::namespace::current]::table configure - unexpected argument count. Require name value pairs" + } + foreach {k v} $args { + switch -- $k { + %topt_switchkeys% {} + default { + error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + #if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { + # error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + #} + } + set checked_opts [list] + foreach {k v} $args { + switch -- $k { + -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set ansi_codes [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend ansi_codes $code + } + } + set ansival [punk::ansi::codetype::sgr_merge_singles $ansi_codes] + lappend checked_opts $k $ansival + } + -frametype - -frametype_header - -frametype_body { + #frametype will raise an error if v is not a valid custom dict or one of the known predefined types such as light,heavy,double etc + lassign [textblock::frametype $v] _cat category _type ftype + lappend checked_opts $k $v + } + -framemap_body - -framemap_header { + #upvar ::textblock::class::opts_table_defaults tdefaults + #set default_bmap [tcl::dict::get $tdefaults -framemap_body] + #todo - check keys and map + if {[llength $v] == 1} { + if {$v eq "default"} { + upvar ::textblock::class::opts_table_defaults tdefaults + set default_map [tcl::dict::get $tdefaults $k] + lappend checked_opts $k $default_map + } else { + error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}" + } + } else { + #safe jumptable test + #dict for {subk subv} $v {} + foreach {subk subv} $v { + switch -- $subk { + topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} + default { + error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" + } + } + #safe jumptable test + #dict for {seg subst} $subv {} + foreach {seg subst} $subv { + switch -- $seg { + hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {} + default { + error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}" + } + } + } + + } + lappend checked_opts $k $v + } + + } + -framelimits_body - -framelimits_header { + set specific_framelimits [list] + foreach fl $v { + switch -- $fl { + "default" { + lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr + } + hl { + lappend specific_framelimits hlt hlb + } + vl { + lappend specific_framelimits vll vlr + } + hlt - hlb - vll - vlr - trc - tlc - blc - brc { + lappend specific_framelimits $fl + } + default { + error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)" + } + } + } + lappend checked_opts $k $specific_framelimits + } + -ansireset { + if {$v eq "\uFFEF"} { + set RST "\x1b\[m" ;#[a] + lappend checked_opts $k $RST + } else { + error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -show_hseps { + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + lappend checked_opts $k $v + #these don't affect column width calculations + } + -show_edge { + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + lappend checked_opts $k $v + #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + } + -show_vseps { + #we allow empty string - so don't use -strict boolean check + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + #affects width calculations + set o_calculated_column_widths [list] + lappend checked_opts $k $v + } + -minwidth - -maxwidth { + set o_calculated_column_widths [list] + lappend checked_opts $k $v + } + default { + lappend checked_opts $k $v + } + } + } + #all options checked - ok to update o_opts_table and o_opts_table_effective + + #set o_opts_table [tcl::dict::merge $o_opts_table $checked_opts] + foreach {k v} $args { + switch -- $k { + -framemap_header - -framemap_body { + #framemaps don't require setting every key to update. + #e.g configure -framemaps {topleft } + #needs to merge with existing unspecified keys such as topright middleleft etc. + if {$v eq "default"} { + tcl::dict::set o_opts_table $k default + } else { + if {[tcl::dict::get $o_opts_table $k] eq "default"} { + tcl::dict::set o_opts_table $k $v + } else { + tcl::dict::set o_opts_table $k [tcl::dict::merge [tcl::dict::get $o_opts_table $k] $v] + } + } + } + -title { + set twidth [punk::ansi::printing_length $v] + if {[my width] < [expr {$twidth+2}]} { + set o_calculated_column_widths [list] + tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] + } + tcl::dict::set o_opts_table -title $v + } + default { + tcl::dict::set o_opts_table $k $v + } + } + } + #use values from checked_opts for the effective opts + #safe jumptable test + #dict for {k v} $checked_opts {} + #foreach {k v} $checked_opts {} + tcl::dict::for {k v} $checked_opts { + switch -- $k { + -framemap_body - -framemap_header { + set existing [tcl::dict::get $o_opts_table_effective $k] + #set updated $existing + #dict for {subk subv} $v { + # tcl::dict::set updated $subk $subv + #} + #tcl::dict::set o_opts_table_effective $k $updated + tcl::dict::set o_opts_table_effective $k [tcl::dict::merge $existing $v] + } + -framelimits_body - -framelimits_header { + #my Set_effective_framelimits + tcl::dict::set o_opts_table_effective $k $v + } + default { + tcl::dict::set o_opts_table_effective $k $v + } + } + } + #ansireset exception + tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] + return $o_opts_table + } + + #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] + if {$table_colcount == 0} { + for {set c 0} {$c < $matrix_colcount} {incr c} { + my add_column -headers "" + } + } + set table_colcount [my column_count] + if {$table_colcount != $matrix_colcount} { + error "textblock::table::printmatrix column count of table doesn't match column count of matrix" + } + if {[my row_count] > 0} { + my row_clear + } + for {set r 0} {$r < $matrix_rowcount} {incr r} { + my add_row [$matrix get row $r] + } + 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 { + set m [struct::matrix $cmd] + } + $m add columns [tcl::dict::size $o_columndata] + $m add rows [tcl::dict::size $o_rowdefs] + tcl::dict::for {k v} $o_columndata { + $m set column $k $v + } + return $m + } + method add_column {args} { + #*** !doctools + #[call class::table [method add_column] [arg args]] + + + if {[llength $args] %2 != 0} { + error "[tcl::namespace::current]::table::add_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" + } + set opts $o_opts_column_defaults + foreach {k v} $args { + switch -- $k { + %copt_switchkeys% { + tcl::dict::set opts $k $v + } + default { + error "[tcl::namespace::current]::table::add_column unknown option '$k'. Known options: %copt_keys%" + } + } + } + set colcount [tcl::dict::size $o_columndefs] + + + tcl::dict::set o_columndata $colcount [list] + #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists + tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists + + + tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] + set prev_calculated_column_widths $o_calculated_column_widths + if {[catch { + my configure_column $colcount {*}$opts + } errMsg]} { + #configure failed - ensure o_columndata and o_columndefs entries are removed + tcl::dict::unset o_columndata $colcount + tcl::dict::unset o_columndefs $colcount + tcl::dict::unset o_columnstates $colcount + #undo cache invalidation + set o_calculated_column_widths $prev_calculated_column_widths + error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" + } + #any add_column that succeeds should invalidate the calculated column widths + set o_calculated_column_widths [list] + set numrows [my row_count] + if {$numrows > 0} { + #fill column with default values + #puts ">>> adding default values for column $colcount" + set dval [tcl::dict::get $opts -defaultvalue] + set width [textblock::width $dval] + tcl::dict::set o_columndata $colcount [lrepeat $numrows $dval] + tcl::dict::set o_columnstates $colcount maxwidthbodyseen $width + tcl::dict::set o_columnstates $colcount minwidthbodyseen $width + } + 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" + } + if {![llength $args]} { + return [tcl::dict::get $o_columndefs $cidx] + } else { + if {[llength $args] == 1} { + if {[lindex $args 0] in [list %copt_keys%]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_columndefs $cidx $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + } else { + error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values %copt_keys%" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" + } + foreach {k v} $args { + switch -- $k { + %copt_switchkeys% {} + default { + error "[tcl::namespace::current]::table configure_column unknown option '$k'. Known options: %copt_keys%" + } + } + } + set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state + + set hstates $o_headerstates ;#operate on a copy + set colstate [tcl::dict::get $o_columnstates $cidx] + set args_got_headers 0 + set args_got_header_colspans 0 + foreach {k v} $args { + switch -- $k { + -headers { + set args_got_headers 1 + set i 0 + set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. + foreach hdr $v { + set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns + #set this_header_height [textblock::height $hdr] + lassign [textblock::size $hdr] _w this_header_width _h this_header_height + + if {$this_header_height >= $currentmax} { + tcl::dict::set hstates $i maxheightseen $this_header_height + } else { + tcl::dict::set hstates $i maxheightseen $currentmax + } + if {$this_header_width >= $maxseen} { + set maxseen $this_header_width + } + #if {$this_header_width > [tcl::dict::get $colstate maxwidthheaderseen]} { + # tcl::dict::set colstate maxwidthheaderseen $this_header_width + #} + incr i + } + tcl::dict::set colstate maxwidthheaderseen $maxseen + #review - we could avoid some recalcs if we check current width range compared to previous + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -header_colspans { + set args_got_header_colspans 1 + #check columns to left to make sure each new colspan for this column makes sense in the overall context + #user may have to adjust colspans in order left to right to avoid these check errors + #note that 'any' represents span all up to the next non-zero defined colspan. + set cspans [my header_colspans] + set h 0 + if {[llength $v] > [tcl::dict::size $cspans]} { + error "configure_column $cidx -header_colspans. Only [tcl::dict::size $cspans] headers exist. Too many values supplied" + } + foreach s $v { + if {$cidx == 0} { + if {[tcl::string::is integer -strict $s]} { + if {$s < 1} { + error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'any' or a positive integer" + } + } else { + if {$s ne "any" && $s ne ""} { + error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" + } + } + } else { + #if {![tcl::string::is integer -strict $s]} { + # if {$s ne "any" && $s ne ""} { + # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" + # } + #} else { + set header_spans [tcl::dict::get $cspans $h] + set remaining [lindex $header_spans 0] + if {$remaining ne "any"} { + incr remaining -1 + } + #look at spans defined for previous cols + #we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption + for {set c 0} {$c < $cidx} {incr c} { + set span [lindex $header_spans $c] + if {$span eq "any"} { + set remaining "any" + } else { + if {$remaining eq "any"} { + if {$span ne "0"} { + #a previous column has ended the 'any' span + set remaining [expr {$span -1}] + } + } else { + if {$span eq "0"} { + incr remaining -1 + } else { + set remaining [expr {$span -1}] + } + #allow to go negative + } + } + } + if {$remaining eq "any"} { + #any int >0 ok - what about 'any' immediately following any? + } else { + if {$remaining > 0} { + if {$s ne "0" && $s ne ""} { + error "configure_column $cidx -header_colspans bad span $s for header '$h'. Remaining span is '$remaining' - so a zero colspan is required" + } + } else { + if {$s == 0} { + error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" + } + } + } + #} + } + incr h + } + #todo - avoid recalc if no change + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -minwidth { + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -maxwidth { + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set col_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend col_ansibase_items $code + } + } + set col_ansibase [punk::ansi::codetype::sgr_merge_singles $col_ansibase_items] + tcl::dict::set checked_opts $k $col_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + tcl::dict::set checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -blockalign - -textalign { + switch -- $v { + left - right { + tcl::dict::set checked_opts $k $v + } + centre - centre { + tcl::dict::set checked_opts $k centre + } + } + } + default { + tcl::dict::set checked_opts $k $v + } + } + } + #args checked - ok to update headerstates, headerdefs and columndefs and columnstates + tcl::dict::set o_columndefs $cidx $checked_opts + set o_headerstates $hstates + dict for {hidx hstate} $hstates { + #configure_header + if {![dict exists $o_headerdefs $hidx]} { + #remove calculated members -values -colspans + set hdefaults [dict remove $o_opts_header_defaults -values -colspans] + dict set o_headerdefs $hidx $hdefaults + } + } + + tcl::dict::set o_columnstates $cidx $colstate + + if {$args_got_headers} { + #if the headerlist length for this column has shrunk,and it was the longest - we may now have excess entries in o_headerstates + set zero_heights [list] + tcl::dict::for {hidx _v} $o_headerstates { + #pass empty string for exclude_column so we don't exclude our own column + if {[my header_height_calc $hidx ""] == 0} { + lappend zero_heights $hidx + } + } + foreach zidx $zero_heights { + tcl::dict::unset o_headerstates $zidx + } + } + if {$args_got_headers || $args_got_header_colspans} { + #check and adjust header_colspans for all columns + + } + + return [tcl::dict::get $o_columndefs $cidx] + } + } + + 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 {} { + set max_headers 0 + tcl::dict::for {k cdef} $o_columndefs { + set num_headers [llength [tcl::dict::get $cdef -headers]] + set max_headers [expr {max($max_headers,$num_headers)}] + } + 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] + } + + #review - use maxwidth (considering colspans) of each column to determine height after wrapping + # -need to consider whether vertical expansion allowed / maxheight? + method header_height_calc {header_index {exclude_column ""}} { + set dataheight 0 + if {$exclude_column eq ""} { + set exclude_colidx "" + } else { + set exclude_colidx [lindex [tcl::dict::keys $o_columndefs] $exclude_column] + } + tcl::dict::for {cidx cdef} $o_columndefs { + if {$exclude_colidx == $cidx} { + continue + } + set headerlist [tcl::dict::get $cdef -headers] + if {$header_index < [llength $headerlist]} { + set this_height [textblock::height [lindex $headerlist $header_index]] + set dataheight [expr {max($dataheight,$this_height)}] + } + } + return $dataheight + } + + #return a dict keyed on header index with values representing colspans + #e.g + # 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] + tcl::dict::for {cidx cdef} $o_columndefs { + set headerlist [tcl::dict::get $cdef -headers] + set colspans_for_column [tcl::dict::get $cdef -header_colspans] + for {set h 0} {$h < $num_headers} {incr h} { + set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] + set defined_span [lindex $colspans_for_column $h] + set i 0 + set spanremaining [lindex $headerspans 0] + if {$spanremaining ne "any"} { + if {$spanremaining eq ""} { + set spanremaining 1 + } + incr spanremaining -1 + } + foreach s $headerspans { + if {$s eq "any"} { + set spanremaining "any" + } elseif {$s == 0} { + if {$spanremaining ne "any"} { + incr spanremaining -1 + } + } else { + set spanremaining [expr {$s - 1}] + } + incr i + } + if {$defined_span eq ""} { + if {$spanremaining eq "0"} { + lappend headerspans 1 + } else { + #"any" or an integer + lappend headerspans 0 + } + } else { + lappend headerspans $defined_span + } + tcl::dict::set colspans_by_header $h $headerspans + } + } + return $colspans_by_header + } + + #e.g + # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 any 1} 3 {any 0 0 1} + #convert to + # 0 {4 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} + method header_colspans_numeric {} { + set hcolspans [my header_colspans] + if {![tcl::dict::size $hcolspans]} { + return + } + set numcols [llength [tcl::dict::get $hcolspans 0]] ;#assert: all are the same + tcl::dict::for {h spans} $hcolspans { + set c 0 ;#column index + foreach s $spans { + if {$s eq "any"} { + set spanlen 1 + for {set i [expr {$c+1}]} {$i < $numcols} {incr i} { + #next 'any' or non-zero ends an 'any' span + if {[lindex $spans $i] ne "0"} { + break + } + incr spanlen + } + #overwrite the 'any' with it's actual span + set modified_spans [dict get $hcolspans $h] + lset modified_spans $c $spanlen + dict set hcolspans $h $modified_spans + } + incr c + } + } + return $hcolspans + } + + method configure_header {index_expression args} { + #*** !doctools + #[call class::table [method configure_header]] + #[para] - configure header row-wise + + #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} + set num_headers [my header_count_calc] + set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression] + if {$hidx eq ""} { + error "textblock::table::configure_header - no header row defined at index '$index_expression'." + } + if {$hidx > $num_headers -1} { + #assert - shouldn't happen + error "textblock::table::configure_header error headerstates data is out of sync" + } + + if {![llength $args]} { + set colspans_by_header [my header_colspans] + set result [tcl::dict::create] + tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] + set header_row_items [list] + tcl::dict::for {cidx cdef} $o_columndefs { + set colheaders [tcl::dict::get $cdef -headers] + set relevant_header [lindex $colheaders $hidx] + #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + } + tcl::dict::set result -values $header_row_items + + #review - ensure always a headerdef record for each header? + if {[tcl::dict::exists $o_headerdefs $hidx]} { + set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]] + } else { + #warn for now + puts stderr "no headerdef record for header $hidx" + } + return $result + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [tcl::dict::keys $o_opts_header_defaults]} { + #query single option + set k [lindex $args 0] + #set val [tcl::dict::get $o_rowdefs $ridx $k] + + set infodict [tcl::dict::create] + #todo + # -blockalignments and -textalignments lists + # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} + #if there is a value it overrides alignments specified on the column + switch -- $k { + -values { + set header_row_items [list] + tcl::dict::for {cidx cdef} $o_columndefs { + set colheaders [tcl::dict::get $cdef -headers] + set relevant_header [lindex $colheaders $hidx] + #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + + } + set val $header_row_items + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + } + -colspans { + set colspans_by_header [my header_colspans] + set result [tcl::dict::create] + set val [tcl::dict::get $colspans_by_header $hidx] + #ansireset not required + set returndict [tcl::dict::create option $k value $val] + } + -ansibase { + set val ??? + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_header_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_header_defaults]" + } + foreach {k v} $args { + if {$k ni [tcl::dict::keys $o_opts_header_defaults]} { + error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_header_defaults]" + } + } + + set checked_opts [list] + #safe jumptable test + #dict for {k v} $args {} + foreach {k v} $args { + switch -- $k { + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set header_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend header_ansibase_items $code + } + } + set header_ansibase [punk::ansi::codetype::sgr_merge_singles $header_ansibase_items] + lappend checked_opts $k $header_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + lappend checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -values { + if {[llength $v] > [tcl::dict::size $o_columndefs]} { + error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" + } + lappend checked_opts $k $v + } + -colspans { + set numcols [tcl::dict::size $o_columndefs] + if {[llength $v] > $numcols} { + error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" + } + if {[llength $v] < $numcols} { + puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." + puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" + } + if {[llength $v]} { + set firstspan [lindex $v 0] + set first_is_ok 0 + if {$firstspan eq "any"} { + set first_is_ok 1 + } elseif {[tcl::string::is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} { + set first_is_ok 1 + } + if {!$first_is_ok} { + error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" + } + #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) + set remaining $firstspan + if {$remaining ne "any"} { + incr remaining -1 + } + set spanview $v + set sidx 1 + #because we allow 'any' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'any' first + foreach span [lrange $v 1 end] { + if {$remaining eq "any"} { + if {$span eq "any"} { + set remaining "any" + } elseif {$span > 0} { + #ok to reset to higher val immediately or after an any and any number of following zeros + if {$span > ($numcols - $sidx)} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" + } + set remaining $span + incr remaining -1 + } else { + #zero following an any - leave remaining as any + } + } else { + if {$span eq "0"} { + if {$remaining eq "0"} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" + } else { + incr remaining -1 + } + } else { + if {$remaining eq "0"} { + #ok for new span value of any or > 0 + if {$span ne "any" && $span > ($numcols - $sidx)} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" + } + set remaining $span + if {$remaining ne "any"} { + incr remaining -1 + } + } else { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" + } + } + } + incr sidx + } + } + #empty -colspans list should be ok + + #error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now" + lappend checked_opts $k $v + } + default { + lappend checked_opts $k $v + } + } + } + + #configured opts all good + #safe jumptable test + #dict for {k v} $checked_opts {} + #foreach {k v} $checked_opts {} + + # headerdefs excludes -values and -colspans + set update_hdefs [tcl::dict::get $o_headerdefs $hidx] + + tcl::dict::for {k v} $checked_opts { + switch -- $k { + -values { + set c 0 + foreach hval $v { + #retrieve -headers from relevant col, insert at header index, and write back. + set thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers] + set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}] + if {$missing > 0} { + lappend thiscol_headers_vertical {*}[lrepeat $missing ""] + } + lset thiscol_headers_vertical $hidx $hval + tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical + #invalidate column width cache + set o_calculated_column_widths [list] + # -- -- -- -- -- -- + #also update maxwidthseen & maxheightseen + set i 0 + set maxwidthseen 0 + #set maxheightseen 0 + foreach hdr $thiscol_headers_vertical { + lassign [textblock::size $hdr] _w this_header_width _h this_header_height + set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0] + if {$this_header_height >= $maxheightseen} { + tcl::dict::set o_headerstates $i maxheightseen $this_header_height + } else { + tcl::dict::set o_headerstates $i maxheightseen $maxheightseen + } + if {$this_header_width >= $maxwidthseen} { + set maxwidthseen $this_header_width + } + incr i + } + tcl::dict::set o_columnstates $c maxwidthheaderseen $maxwidthseen + # -- -- -- -- -- -- + incr c + } + } + -colspans { + #sequence has been verified above - we need to split it and store across columns + set c 0 ;#column index + foreach span $v { + set colspans [tcl::dict::get $o_columndefs $c -header_colspans] + if {$hidx > [llength $colspans]-1} { + set colspans_by_header [my header_colspans] + #puts ">>>>>?$colspans_by_header" + #we are allowed to lset only one beyond the current length to append + #but there may be even less or no entries present in a column + # - the ability to underspecify and calculate the missing values makes setting the values complicated. + #use the header_colspans calculation to update only those entries necessary + set spanlist [list] + for {set h 0} {$h < $hidx} {incr h} { + set cspans [tcl::dict::get $colspans_by_header $h] + set requiredval [lindex $cspans $c] + lappend spanlist $requiredval + } + tcl::dict::set o_columndefs $c -header_colspans $spanlist + + set colspans [tcl::dict::get $o_columndefs $c -header_colspans] + } + + lset colspans $hidx $span + tcl::dict::set o_columndefs $c -header_colspans $colspans + incr c + } + } + default { + dict set update_hdefs $k $v + } + } + } + set opt_minh [tcl::dict::get $update_hdefs -minheight] + set opt_maxh [tcl::dict::get $update_hdefs -maxheight] + + #todo - allow zero values to hide/collapse + # - see also configure_row + if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { + error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" + } + if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { + error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" + } + if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { + error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" + } + + #set o_headerstate $hidx -minheight? -maxheight? ??? + tcl::dict::set o_headerdefs $hidx $update_hdefs + } + + method add_row {valuelist args} { + #*** !doctools + #[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 + append msg "rowdata: $valuelist" + error $msg + } + if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { + error "add_row - no values supplied, and no columns defined, so cannot use default column values" + } + + set defaults [tcl::dict::create\ + -minheight 1\ + -maxheight ""\ + -ansibase ""\ + -ansireset "\uFFEF"\ + ] + set o_opts_row_defaults $defaults + + if {[llength $args] %2 !=0} { + error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" + } + #safe jumptable test + #dict for {k v} $args {} + foreach {k v} $args { + switch -- $k { + -minheight - -maxheight - -ansibase - -ansireset {} + default { + error "Invalid option '$k' Known options: [tcl::dict::keys $defaults] (-ansireset is read-only)" + } + } + } + set opts [tcl::dict::merge $defaults $args] + + set auto_columns 0 + if {[tcl::dict::size $o_columndefs] == 0} { + set auto_columns 1 + #no columns defined - auto define with defaults for each column in first supplied row + #auto define columns only valid if no existing columns + #the autocolumns must be added before configure_row - but if configure_row fails - we need to remove them! + foreach el $valuelist { + my add_column + } + } else { + if {![llength $valuelist]} { + tcl::dict::for {k coldef} $o_columndefs { + lappend valuelist [tcl::dict::get $coldef -defaultvalue] + } + } + } + set rowcount [tcl::dict::size $o_rowdefs] + tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure + + if {[catch { + my configure_row $rowcount {*}$opts + } errMsg]} { + #undo anything we saved before configure_row + tcl::dict::unset o_rowdefs $rowcount + #remove auto_columns + if {$auto_columns} { + set o_columndata [tcl::dict::create] + set o_columndefs [tcl::dict::create] + set o_columnstate [tcl::dict::create] + } + error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" + } + + + set c 0 + set max_height_seen 1 + foreach v $valuelist { + set prev_maxwidth [tcl::dict::get $o_columnstates $c maxwidthbodyseen] + set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] + + tcl::dict::lappend o_columndata $c $v + lassign [textblock::size_as_list $v] valwidth valheight + if {$valheight > $max_height_seen} { + set max_height_seen $valheight + } + if {$valwidth > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { + tcl::dict::set o_columnstates $c maxwidthbodyseen $valwidth + } + 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} { + #invalidate calculated column width cache if any new value was outside the previous range of widths + set o_calculated_column_widths [list] + } + incr c + } + + set opt_maxh [tcl::dict::get $o_rowdefs $rowcount -maxheight] + if {$opt_maxh ne ""} { + tcl::dict::set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}] + } else { + tcl::dict::set o_rowstates $rowcount -maxheight $max_height_seen + } + + 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" + } + if {![llength $args]} { + return [tcl::dict::get $o_rowdefs $ridx] + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [tcl::dict::keys $o_opts_row_defaults]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_rowdefs $ridx $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_row_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_row_defaults]" + } + foreach {k v} $args { + if {$k ni [tcl::dict::keys $o_opts_row_defaults]} { + error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_row_defaults]" + } + } + set checked_opts [list] + foreach {k v} $args { + switch -- $k { + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set row_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend row_ansibase_items $code + } + } + set row_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] + lappend checked_opts $k $row_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + lappend checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_row -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + default { + lappend checked_opts $k $v + } + } + } + + set current_opts [tcl::dict::get $o_rowdefs $ridx] + set opts [tcl::dict::merge $current_opts $checked_opts] + + #check minheight and maxheight together + set opt_minh [tcl::dict::get $opts -minheight] + set opt_maxh [tcl::dict::get $opts -maxheight] + + #todo - allow zero values to hide/collapse rows as is possible with columns + if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { + error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" + } + if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { + error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" + } + if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { + error "[tcl::namespace::current]::table::configure_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" + } + tcl::dict::set o_rowstates $ridx -minheight $opt_minh + + + 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 + tcl::dict::for {cidx records} $o_columndata { + tcl::dict::set o_columndata $cidx [list] + #reset only the body fields in o_columnstates + tcl::dict::set o_columnstates $cidx minwidthbodyseen 0 + tcl::dict::set o_columnstates $cidx maxwidthbodyseen 0 + } + 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] + set o_columnstates [tcl::dict::create] + } + + + + #method Get_columns_by_name {namematch_list} { + #} + + #specify range with x..y + method Get_columns_by_indices {index_list} { + foreach spec $index_list { + if {[tcl::string::is integer -strict $c]} { + set colidx $c + } else { + tcl::dict::for {colidx coldef} $o_columndefs { + #if {[tcl::string::match x x]} {} + } + } + } + } + method Get_boxlimits_and_joins {position fname_body} { + #fname_body will be "custom" or one of the predefined types light,heavy etc + switch -- $position { + left { + return [tcl::dict::create \ + boxlimits [list hlb blc vll]\ + boxlimits_top [list hlb blc vll hlt tlc]\ + joins [list down]\ + bodyjoins [list down-$fname_body]\ + ] + } + inner { + return [tcl::dict::create \ + boxlimits [list hlb blc vll]\ + boxlimits_top [list hlb blc vll hlt tlc]\ + joins [list down left]\ + bodyjoins [list left down-$fname_body] + ] + } + right { + return [tcl::dict::create \ + boxlimits [list hlb blc vll vlr brc]\ + boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ + joins [list down left]\ + bodyjoins [list left down-$fname_body]\ + ] + } + solo { + return [tcl::dict::create \ + boxlimits [list hlb blc vll vlr brc]\ + boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ + joins [list down]\ + bodyjoins [list down-$fname_body]\ + ] + } + default { + error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo" + } + } + } + method Get_boxlimits_and_joins1 {position fname_body} { + #fname_body will be "custom" or one of the predefined types light,heavy etc + switch -- $position { + left { + #set header_boxlimits {hlb hlt tlc blc vll} + set header_body_joins [list down-$fname_body] + set boxlimits_position [list hlb blc vll] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] + set boxlimits_toprow [list hlb blc vll hlt tlc] + set joins [list down] + } + inner { + #set header_boxlimits {hlb hlt tlc blc vll} + set header_body_joins [list left down-$fname_body] + set boxlimits_position [list hlb blc vll] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] + set boxlimits_toprow [list hlb blc vll hlt tlc] + set joins [list down left] + } + right { + #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} + set header_body_joins [list left down-$fname_body] + set boxlimits_position [list hlb blc vll vlr brc] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] + set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] + set joins [list down left] + } + solo { + #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} + set header_body_joins [list down-$fname_body] + set boxlimits_position [list hlb blc vll vlr brc] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] + set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] + set joins [list down] + } + } + return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ] + } + method get_column_by_index {index_expression args} { + #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" + #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. + set opts [tcl::dict::create\ + -position "inner"\ + -return "string"\ + ] + foreach {k v} $args { + switch -- $k { + -position - -return { + tcl::dict::set opts $k $v + } + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid option '$k'. Known options [tcl::dict::keys $opts]" + } + } + } + set opt_posn [tcl::dict::get $opts -position] + set opt_return [tcl::dict::get $opts -return] + + switch -- $opt_posn { + left - inner - right - solo {} + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo]" + } + } + switch -- $opt_return { + string - dict {} + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_return' for -return. Valid values: string dict" + } + } + + set columninfo [my get_column_cells_by_index $index_expression] + set header_list [tcl::dict::get $columninfo headers] + #puts "===== header_list: $header_list" + set cells [tcl::dict::get $columninfo cells] + + set topt_show_header [tcl::dict::get $o_opts_table -show_header] + if {$topt_show_header eq ""} { + set allheaders 0 + set all_cols [tcl::dict::keys $o_columndefs] + foreach c $all_cols { + incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] + } + if {$allheaders == 0} { + set do_show_header 0 + } else { + set do_show_header 1 + } + } else { + set do_show_header $topt_show_header + } + set topt_show_footer [tcl::dict::get $o_opts_table -show_footer] + + + set output "" + set part_header "" + set part_body "" + set part_footer "" + + set boxlimits "" + set joins "" + set header_boxlimits [list] + set header_body_joins [list] + + + set ftypes [my Get_frametypes] + set ftype_body [tcl::dict::get $ftypes body] + if {[llength $ftype_body] >= 2} { + set fname_body "custom" + } else { + set fname_body $ftype_body + } + set ftype_header [tcl::dict::get $ftypes header] + if {[llength $ftype_header] >= 2} { + set fname_header "custom" + } else { + set fname_header $ftype_header + } + + set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] + set header_body_joins [tcl::dict::get $limj bodyjoins] + set joins [tcl::dict::get $limj joins] + set boxlimits_position [tcl::dict::get $limj boxlimits] + set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] + #use struct::set instead of simple for loop - will be faster at least when critcl available + set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] + set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] + set header_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_position] + set header_boxlimits_toprow [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_toprow] + + set fmap [tcl::dict::get $o_opts_table_effective -framemap_body] + set hmap [tcl::dict::get $o_opts_table_effective -framemap_header] + + #if {![tcl::dict::get $o_opts_table -show_edge]} { + # set body_edgemap [textblock::class::table_edge_map ""] + # dict for {k v} $fmap { + # #tcl::dict::set fmap $k [tcl::dict::merge $v [tcl::dict::get $body_edgemap $k]] + # } + # set header_edgemap [textblock::class::header_edge_map ""] + # dict for {k v} $hmap { + # #tcl::dict::set hmap $k [tcl::dict::merge $v [tcl::dict::get $header_edgemap $k]] + # } + #} + set sep_elements_horizontal $::textblock::class::table_hseps + set sep_elements_vertical $::textblock::class::table_vseps + + set topmap [tcl::dict::get $fmap top$opt_posn] + set botmap [tcl::dict::get $fmap bottom$opt_posn] + set midmap [tcl::dict::get $fmap middle$opt_posn] + set onlymap [tcl::dict::get $fmap only$opt_posn] + + set hdrmap [tcl::dict::get $hmap only${opt_posn}] + + set topseps_h [tcl::dict::get $sep_elements_horizontal top$opt_posn] + set midseps_h [tcl::dict::get $sep_elements_horizontal middle$opt_posn] + set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] + set midseps_v [tcl::dict::get $sep_elements_vertical middle$opt_posn] + set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] + set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] + + #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway + set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] + + lassign [my Get_seps] _h show_seps_h _v show_seps_v + set return_headerheight 0 + set return_headerwidth 0 + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + + set colwidth [my column_width $cidx] + + set col_blockalign [tcl::dict::get $o_columndefs $cidx -blockalign] + + if {$do_show_header} { + #puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap" + set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure + set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] + if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { + set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] + set ansiborder_final $ansibase_header$ansiborder_header$extrabg + } else { + set ansiborder_final $ansibase_header$ansiborder_header + } + set RST [punk::ansi::a] + + + set hcolwidth $colwidth + #set hcolwidth [my column_width_configured $cidx] + set hcell_line_blank [tcl::string::repeat " " $hcolwidth] + + set all_colspans [my header_colspans_numeric] + + #put our framedef calls together + set fdef_header [textblock::framedef $ftype_header] + set framedef_leftbox [textblock::framedef -joins left $ftype_header] + set framedef_headerdown_same [textblock::framedef -joins {down} $ftype_header] + set framedef_headerdown_body [textblock::framedef -joins [list down-$fname_body] $ftype_header] + #default span_extend_map - used as base to customise with specific joins + set span_extend_map [tcl::dict::create \ + vll " "\ + tlc [tcl::dict::get $fdef_header hlt]\ + blc [tcl::dict::get $fdef_header hlb]\ + ] + + + #used for colspan-zero header frames + set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test + + set hrow 0 + set hmax [expr {[llength $header_list] -1}] + foreach header $header_list { + set headerspans [tcl::dict::get $all_colspans $hrow] + set this_span [lindex $headerspans $cidx] + #set hval $ansibase_header$header ;#no reset + set hval $header + set rowh [my header_height $hrow] + + if {$hrow == 0} { + set hlims $header_boxlimits_toprow + set rowpos "top" + if {$hrow == $hmax} { + set rowpos "only" + } + } else { + set hlims $header_boxlimits + set rowpos "middle" + if {$hrow == $hmax} { + set rowpos "bottom" + } + } + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {$hrow == $hmax} { + set header_joins $header_body_joins + } else { + set header_joins $joins + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + } + #puts ">>> headerspans: $headerspans cidx: $cidx" + + #if {$this_span eq "any" || $this_span > 0} {} + #changed to processing only numeric colspans + + if {$this_span > 0} { + set startmap [tcl::dict::get $hmap $rowpos${opt_posn}] + #look at spans in header below to determine joins required at blc + if {$show_seps_v} { + if {[tcl::dict::exists $all_colspans [expr {$hrow+1}]]} { + set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] + set spanbelow [lindex $next_spanlist $cidx] + if {$spanbelow == 0} { + #we don't want a down-join for blc - use a framedef with only left joins + tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] + } + } else { + set next_spanlist [list] + } + } + + #supporting wrapping in headers might be a step too difficult for little payoff. + #we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib) + #The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex. + #May be better to require user to pre-wrap as needed + ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] + + #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used + #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) + + # -width is always +2 - as the boxlimits take into account show_vseps and show_edge + #set header_cell_startspan [textblock::frame -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 $hval\ + # ] + + if {$this_span == 1} { + #write the actual value now + set cellcontents $hval + } else { + #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 -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\ + ] + + if {$this_span != 1} { + #puts "===>\n$header_cell_startspan\n<===" + set spanned_parts [list $header_cell_startspan] + #assert this_span == "any" or >1 ie a header that spans other columns + #therefore more parts to append + #set remaining_cols [lrange [tcl::dict::keys $o_columndefs] $cidx end] + set remaining_spans [lrange $headerspans $cidx+1 end] + set spanval [join $remaining_spans ""] ;#so we can test for all zeros + set spans_to_rhs 0 + if {[expr {$spanval}] == 0} { + #puts stderr "SPANS TO RHS" + set spans_to_rhs 1 + } + + #puts ">> remaining_spans: $remaining_spans" + set spancol [expr {$cidx + 1}] + set h_lines [lrepeat $rowh ""] + set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + + + + set last [expr {[llength $remaining_spans] -1}] + set i 0 + foreach s $remaining_spans { + if {$s == 0} { + if {$i == $last} { + set next_posn right + #set next_posn inner + } else { + set next_posn inner + } + + set next_headerseps_v [tcl::dict::get $sep_elements_vertical top$next_posn] ;#static top ok + + set limj [my Get_boxlimits_and_joins $next_posn $fname_body] + set span_joins_body [tcl::dict::get $limj bodyjoins] + set span_joins [tcl::dict::get $limj joins] + set span_boxlimits [tcl::dict::get $limj boxlimits] + set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] + #use struct::set instead of simple for loop - will be faster at least when critcl available + #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] + #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] + set header_span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits] + set header_span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits_top] + if {$hrow == 0} { + set hlims $header_span_boxlimits_top + } else { + set hlims $header_span_boxlimits + } + + set this_span_map $span_extend_map + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $next_headerseps_v] + } else { + if {[llength $next_spanlist]} { + set spanbelow [lindex $next_spanlist $spancol] + if {$spanbelow != 0} { + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype + } + } else { + #join to body + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype + } + } + + if {$hrow == $hmax} { + set header_joins $span_joins_body + } else { + set header_joins $span_joins + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] + } + + set contentwidth [my column_width $spancol] + set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [tcl::dict::get $ftypes header]\ + -ansibase $ansibase_header -ansiborder $ansiborder_final\ + -boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\ + ] + lappend spanned_parts $header_cell + } else { + break + } + incr spancol + incr i + } + + #JMN + #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic + set spanned_frame [textblock::join_basic -- {*}$spanned_parts] + + if {$spans_to_rhs} { + if {$cidx == 0} { + set fake_posn solo + } else { + set fake_posn right + } + set x_limj [my Get_boxlimits_and_joins $fake_posn $fname_body] + if {$hrow == 0} { + set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] + } else { + set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] + } + } else { + if {$hrow == 0} { + set hlims $header_boxlimits_toprow + } else { + set hlims $header_boxlimits + } + } + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + if {$spans_to_rhs} { + #assert fake_posn has been set above based on cidx and spans_to_rhs + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts ${rowpos}$fake_posn] ] + } else { + #use the edge_parts corresponding to the column being written to ie use opt_posn + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + } + } + + set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements + #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 -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]" + #puts "==>hval:'[ansistring VIEW $hval]'" + #set spanned_frame [overtype::renderspace -transparent 1 $spanned_frame $hblock] + + #spanned values default left - todo make configurable + + #TODO + #consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span + #we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes? + #this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span. + #(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned) + + set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] + #POTENTIAL BUG (fixed with spans_to_rhs above) + #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) + #we need to shift 1 to the left when doing our overtype with blockalign right + #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge + #(even though the column position may be left or inner) + + + + } else { + #this_span == 1 + set spanned_frame [textblock::join_basic -- $header_cell_startspan] + } + + + append part_header $spanned_frame + append part_header \n + } else { + #zero span header directly in this column ie one that is being colspanned by some column to our left + #previous col will already have built lines for this in it's own header rhs overhang + #we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent. + + #set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1] + + #if there are no header elements above then we will need a minimum of the column width + #may be extended to the widest portion of the header in the loop below + set padwidth [my column_width $cidx] + + + #under assumption we are building table using L frame method and that horizontal borders are only ever 1 high + # - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc + #avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 ) + if 0 { + #breaks -show_edge 0 + if {$rowpos eq "top" && [tcl::dict::get $o_opts_table -show_edge]} { + set padheight [expr {$rowh + 2}] + } else { + set padheight [expr {$rowh + 1}] + } + set bline [tcl::string::repeat $TSUB [expr {$padwidth +1}]] + set h_lines [lrepeat $padheight $bline] + set hcell_blank [::join $h_lines \n] + set header_frame $hcell_blank + } else { + set bline [tcl::string::repeat $TSUB $padwidth] + set h_lines [lrepeat $rowh $bline] + set hcell_blank [::join $h_lines \n] + # -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 -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ + -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ + ] + } + + append part_header $header_frame\n + + } + incr hrow + } + if {![llength $header_list]} { + #no headers - but we've been asked to show_header + #display a zero content-height header (ie outline if edge is being shown - or bottom bar) + set hlims $header_boxlimits_toprow + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + 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 -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\ + ] + append part_header $header_frame\n + } + set part_header [tcl::string::trimright $part_header \n] + lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight + + set padline [tcl::string::repeat $TSUB $return_headerwidth] + set adjusted_lines [list] + foreach ln [split $part_header \n] { + if {[tcl::string::first $TSUB $ln] >=0} { + lappend adjusted_lines $padline + } else { + lappend adjusted_lines $ln + } + } + set part_header [::join $adjusted_lines \n] + #append output $part_header \n + } + + set r 0 + set rmax [expr {[llength $cells]-1}] + + + set blims_mid $boxlimits + set blims_top $boxlimits + set blims_bot $boxlimits + set blims_top_headerless $boxlimits_headerless + set blims_only $boxlimits + set blims_only_headerless $boxlimits_headerless + if {!$show_seps_h} { + set blims_mid [struct::set difference $blims_mid $midseps_h] + set blims_top [struct::set difference $blims_top $topseps_h] + set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_h] + } + if {!$show_seps_v} { + set blims_mid [struct::set difference $blims_mid $midseps_v] + set blims_top [struct::set difference $blims_top $topseps_v] + set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_v] + set blims_bot [struct::set difference $blims_bot $botseps_v] + set blims_only [struct::set difference $blims_only $onlyseps_v] + set blims_only_headerless [struct::set difference $blims_only_headerless $onlyseps_v] + } + + set colidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range + + set opt_col_ansibase [tcl::dict::get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column + #set colwidth [my column_width $colidx] + + set body_ansibase [tcl::dict::get $o_opts_table -ansibase_body] + #set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body + set body_ansiborder [tcl::dict::get $o_opts_table -ansiborder_body] + if {[tcl::dict::get $o_opts_table -frametype] eq "block"} { + #block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled + #we need to only accept background ansi codes from the columndef ansibase for this + set col_bg [punk::ansi::codetype::sgr_merge_singles [list $opt_col_ansibase] -filter_fg 1] ;#special merge for block borders - don't override fg colours + set border_ansi $body_ansibase$body_ansiborder$col_bg + } else { + set border_ansi $body_ansibase$body_ansiborder + } + + + set r 0 + set ftblock [expr {[tcl::dict::get $o_opts_table -frametype] eq "block"}] + foreach c $cells { + #cells in column - each new c is in a different row + set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] + set row_bg "" + if {$row_ansibase ne ""} { + set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] + } + + set ansibase $body_ansibase$opt_col_ansibase + #todo - joinleft,joinright,joindown based on opts in args + set cell_ansibase "" + + set ansiborder_body_col_row $border_ansi$row_bg + set ansiborder_final $ansiborder_body_col_row + #$c will always have ansi resets due to overtype behaviour ? + #todo - review overtype + if {[punk::ansi::ta::detect $c]} { + #use only the last ansi sequence in the cell value + #Filter out foreground and use background for ansiborder override + set parts [punk::ansi::ta::split_codes_single $c] + #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt + set codes [list] + foreach {pt cd} $parts { + if {$cd ne ""} { + lappend codes $cd + } + } + #set takebg [lindex $parts end-1] + #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] + set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] + #puts --->[ansistring VIEW $codes] + + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { + #special case double reset at end of content + set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters + set ansibase "" + set row_ansibase "" + if {$ftblock} { + set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1] + } + set cell_ansibase $cell_ansi_tail + } else { + #single trailing reset in content + set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase + } + } else { + if {$ftblock} { + #no resets - use cell's bg to extend to the border - only for block frames + set ansiborder_final $ansiborder_body_col_row$cell_bg + } + set cell_ansibase $cell_bg + } + } + + set ansibase_final $ansibase$row_ansibase$cell_ansibase + + if {$r == 0} { + if {$r == $rmax} { + set joins [lremove $joins [lsearch $joins down*]] + set bmap $onlymap + if {$do_show_header} { + set blims $blims_only + } else { + set blims $blims_only_headerless + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] + } + } else { + set bmap $topmap + if {$do_show_header} { + set blims $blims_top + } else { + set blims $blims_top_headerless + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] + } + } + 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 { + if {$r == $rmax} { + set joins [lremove $joins [lsearch $joins down*]] + set bmap $botmap + set blims $blims_bot + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts bottom$opt_posn] ] + } + } else { + set bmap $midmap + set blims $blims_mid ;#will only be reduced from boxlimits if -show_seps was processed above + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] + } + } + 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 + } + #return empty (zero content height) row if no rows + if {![llength $cells]} { + set joins [lremove $joins [lsearch $joins down*]] + #we need to know the width of the column to setup the empty cell properly + #even if no header displayed - we should take account of any defined column widths + set colwidth [my column_width $index_expression] + + if {$do_show_header} { + set blims $blims_only + } else { + append part_body \n + set blims $blims_only_headerless + } + #note that if show_edge is 0 - then for this empty line - we will not expect to see any bars + #This is because the frame with no data had vertical components made entirely of corner elements + #we could just append a newline when -show_edge is zero, but we want the correct width even when empty - for proper column joins when there are colspanned headers. + # + if {![tcl::dict::get $o_opts_table -show_edge]} { + #set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] + #append output [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n + append part_body [tcl::string::repeat " " $colwidth] \n + set return_bodywidth $colwidth + } else { + 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] + } + } + #assert bodywidth is integer >=0 whether there are rows or not + + #trim only 1 newline + if {[tcl::string::index $part_body end] eq "\n"} { + set part_body [tcl::string::range $part_body 0 end-1] + } + set return_bodyheight [textblock::height $part_body] + #append output $part_body + + if {$opt_return eq "string"} { + if {$part_header ne ""} { + set output $part_header + if {$part_body ne ""} { + append output \n $part_body + } + } else { + set output $part_body + } + return $output + } else { + return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] + } + } + + 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 "" + if {[tcl::dict::size $o_columndefs] > 0} { + set range "0..[expr {[tcl::dict::size $o_columndefs] -1}]" + } else { + set range empty + } + error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" + } + #assert cidx is integer >=0 + set num_header_rows [my header_count] + set cdef [tcl::dict::get $o_columndefs $cidx] + set headerlist [tcl::dict::get $cdef -headers] + set ansibase_col [tcl::dict::get $cdef -ansibase] + set textalign [tcl::dict::get $cdef -textalign] + switch -- $textalign { + left {set pad right} + right {set pad left} + default { + set pad "centre" ;#todo? + } + } + + #set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] + #set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] + + #set header_underlay $ansibase_header$cell_line_blank + + #set hdrwidth [my column_width_configured $cidx] + #set all_colspans [my header_colspans] + #we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric + set all_colspans [my header_colspans_numeric] + #JMN + #store configured widths so we don't look up for each header line + #set configured_widths [list] + #foreach c [tcl::dict::keys $o_columndefs] { + # #lappend configured_widths [my column_width $c] + # #we don't just want the width of the column in the body - or the headers will get truncated + # lappend configured_widths [my column_width_configured $c] + #} + + set output [tcl::dict::create] + tcl::dict::set output headers [list] + + set showing_vseps [my Showing_vseps] + for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} { + set hdr [lindex $headerlist $hrow] + #jjj + set header_maxdataheight [tcl::dict::get $o_headerstates $hrow maxheightseen] + #set header_maxdataheight [my header_height $hrow] ;#from cached headerstates + set headerdefminh [tcl::dict::get $o_headerdefs $hrow -minheight] + set headerdefmaxh [tcl::dict::get $o_headerdefs $hrow -maxheight] + if {"$headerdefminh$headerdefmaxh" ne "" && $headerdefminh eq $headerdefmaxh} { + set headerh $headerdefminh ;#exact height defined for the row + } else { + if {$headerdefminh eq ""} { + if {$headerdefmaxh eq ""} { + #both defs empty + set headerh $header_maxdataheight + } else { + set headerh [expr {min(1,$headerdefmaxh,$header_maxdataheight)}] + } + } else { + if {$headerdefmaxh eq ""} { + set headerh [expr {max($headerdefminh,$header_maxdataheight)}] + } else { + if {$header_maxdataheight < $headerdefminh} { + set headerh $headerdefminh + } else { + set headerh [expr {max($headerdefminh,$header_maxdataheight)}] + } + } + } + } + + + set headerrow_colspans [tcl::dict::get $all_colspans $hrow] + set this_span [lindex $headerrow_colspans $cidx] + + #set this_hdrwidth [lindex $configured_widths $cidx] + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign + + set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] + set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] + set hval_lines [split $hdr \n] + #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] + tcl::dict::lappend output headers $hcell + } + + + #set colwidth [my column_width $cidx] + #set cell_line_blank [tcl::string::repeat " " $colwidth] + set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1] + set cell_line_blank [tcl::string::repeat " " $datawidth] + + + + set items [tcl::dict::get $o_columndata $cidx] + #puts "---> columndata $o_columndata" + + #set opt_row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] + #set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase + + tcl::dict::set output cells [list];#ensure we return something for cells key if no items in list + set r 0 + foreach cval $items { + #todo move to row_height method ? + set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] + set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] + set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] + if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { + set rowh $rowdefminh ;#an exact height is defined for the row + } else { + if {$rowdefminh eq ""} { + if {$rowdefmaxh eq ""} { + #both defs empty + set rowh $maxdataheight + } else { + set rowh [expr {min(1,$rowdefmaxh,$maxdataheight)}] + } + } else { + if {$rowdefmaxh eq ""} { + set rowh [expr {max($rowdefminh,$maxdataheight)}] + } else { + if {$maxdataheight < $rowdefminh} { + set rowh $rowdefminh + } else { + set rowh [expr {max($rowdefminh,$maxdataheight)}] + } + } + } + } + + set cell_lines [lrepeat $rowh $cell_line_blank] + #set cell_blank [join $cell_lines \n] + + + set cval_lines [split $cval \n] + #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] + + #//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 + + incr r + } + 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 + } + 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\ + ] + foreach {k v} $args { + switch -- $k { + -usetables {} + default { + error "table debug unrecognised option '$k'. Known options: [tcl::dict::keys $defaults]" + } + } + } + set opts [tcl::dict::merge $defaults $args] + set opt_usetables [tcl::dict::get $opts -usetables] + + puts stdout "rowdefs: $o_rowdefs" + puts stdout "rowstates: $o_rowstates" + #puts stdout "columndefs: $o_columndefs" + puts stdout "columndefs:" + if {!$opt_usetables} { + tcl::dict::for {k v} $o_columndefs { + puts " $k $v" + } + } else { + set t [textblock::class::table new] + $t add_column -headers "Col" + tcl::dict::for {col coldef} $o_columndefs { + foreach property [tcl::dict::keys $coldef] { + if {$property eq "-ansireset"} { + continue + } + $t add_column -headers $property + } + break + } + + #build our inner tables first so we can sync widths + set col_header_tables [tcl::dict::create] + set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths + tcl::dict::for {col coldef} $o_columndefs { + set row [list $col] + set colheaders [tcl::dict::get $coldef -headers] + #inner table probably overkill here ..but just as easy + set htable [textblock::class::table new] + $htable configure -show_header 1 -show_edge 0 -show_hseps 0 + $htable add_column -headers row + $htable add_column -headers text + $htable add_column -headers WxH + $htable add_column -headers span + set hnum 0 + set spans [tcl::dict::get $o_columndefs $col -header_colspans] + foreach h $colheaders s $spans { + lassign [textblock::size $h] _w width _h height + $htable add_row [list "$hnum " $h "${width}x${height}" $s] + incr hnum + } + $htable configure_column 0 -ansibase [a+ web-dimgray] + tcl::dict::set col_header_tables $col $htable + set colwidths [$htable column_widths] + set icol 0 + foreach w $colwidths { + if {$w > [tcl::dict::get $max_widths $icol]} { + tcl::dict::set max_widths $icol $w + } + incr icol + } + } + + #safe jumptable test + #dict for {col coldef} $o_columndefs {} + tcl::dict::for {col coldef} $o_columndefs { + set row [list $col] + #safe jumptable test + #dict for {property val} $coldef {} + tcl::dict::for {property val} $coldef { + switch -- $property { + -ansireset {continue} + -headers { + set htable [tcl::dict::get $col_header_tables $col] + tcl::dict::for {innercol maxw} $max_widths { + $htable configure_column $innercol -minwidth $maxw -blockalign left + } + lappend row [$htable print] + $htable destroy + } + default { + lappend row $val + } + } + } + $t add_row $row + } + + + + + $t configure -show_header 1 + puts stdout [$t print] + $t destroy + } + puts stdout "columnstates: $o_columnstates" + puts stdout "headerdefs: $o_headerdefs" + puts stdout "headerstates: $o_headerstates" + tcl::dict::for {k coldef} $o_columndefs { + if {[tcl::dict::exists $o_columndata $k]} { + set headerlist [tcl::dict::get $coldef -headers] + set coldata [tcl::dict::get $o_columndata $k] + set colinfo "rowcount: [llength $coldata]" + set allfields [concat $headerlist $coldata] + if {[llength $allfields]} { + set widest [tcl::mathfunc::max {*}[lmap v $allfields {textblock::width $v}]] + } else { + set widest 0 + } + append colinfo " widest of headers and data: $widest" + } else { + set colinfo "WARNING - no columndata record for column key '$k'" + } + puts stdout "column $k columndata info: $colinfo" + } + set result "" + set cols [list] + set max [expr {[tcl::dict::size $o_columndefs]-1}] + foreach c [tcl::dict::keys $o_columndefs] { + if {$c == 0} { + lappend cols [my get_column_by_index $c -position left] " " + } elseif {$c == $max} { + lappend cols [my get_column_by_index $c -position right] + } else { + lappend cols [my get_column_by_index $c -position inner] " " + } + } + append result [textblock::join -- {*}$cols] + return $result + } + #column width including headers - but without colspan consideration + method column_width_configured {index_expression} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + #assert cidx is now >=0 integer within the range of defined columns + set cdef [tcl::dict::get $o_columndefs $cidx] + set defminw [tcl::dict::get $cdef -minwidth] + set defmaxw [tcl::dict::get $cdef -maxwidth] + if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { + #an exact width is defined for the column - no need to look at data width + set colwidth $defminw + } else { + #set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1] + set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + #set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1] + #set hwidest_singlespan ?? + set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + set widest [expr {max($hwidest,$bwidest)}] + #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. + #if so - a truncated line shouldn't be included in our width calculation + if {$defminw eq ""} { + if {$defmaxw eq ""} { + set colwidth $widest + } else { + set colwidth [expr {min($defmaxw,$widest)}] + } + } else { + if {$defmaxw eq ""} { + set colwidth [expr {max($defminw,$widest)}] + } else { + if {$widest < $defminw} { + set colwidth $defminw + } else { + if {$widest > $defmaxw} { + set colwidth $defmaxw + } else { + set colwidth [expr {max($defminw,$widest)}] + } + } + } + } + } + return $colwidth + } + + 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 + } + return $o_calculated_column_widths + } + + #width of a table includes borders and seps + #whereas width of a column refers to the borderless width (inner width) + method width {} { + #*** !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 + if {[my Showing_vseps]} { + incr twidth [llength $colwidths] + incr twidth -1 + } + if {[tcl::dict::get $o_opts_table -show_edge]} { + incr twidth 2 + } + return $twidth + } + + #column *body* content width + method basic_column_width {index_expression} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + #puts "===column_width $index_expression" + #assert cidx is now >=0 integer within the range of defined columns + set cdef [tcl::dict::get $o_columndefs $cidx] + set defminw [tcl::dict::get $cdef -minwidth] + set defmaxw [tcl::dict::get $cdef -maxwidth] + if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { + #an exact width is defined for the column - no need to look at data width + #review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header + set colwidth $defminw + } else { + #set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0] + set widest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. + #if so - a truncated line shouldn't be included in our width calculation + if {$defminw eq ""} { + if {$defmaxw eq ""} { + set colwidth $widest + } else { + set colwidth [expr {min($defmaxw,$widest)}] + } + } else { + if {$defmaxw eq ""} { + set colwidth [expr {max($defminw,$widest)}] + } else { + if {$widest < $defminw} { + set colwidth $defminw + } else { + if {$widest > $defmaxw} { + set colwidth $defmaxw + } else { + set colwidth [expr {max($defminw,$widest)}] + } + } + } + } + } + set configured_widths [list] + foreach c [tcl::dict::keys $o_columndefs] { + lappend configured_widths [my column_width_configured $c] + } + set header_colspans [my header_colspans] + set width_max $colwidth + set test_width $colwidth + set showing_vseps [my Showing_vseps] + set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + tcl::dict::for {h colspans} $header_colspans { + set spanc [lindex $colspans $cidx] + #set headers [tcl::dict::get $cdef -headers] + #set thiscol_widest_header 0 + #if {[llength $headers] > 0} { + # set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]] + #} + if {$spanc eq "1"} { + if {$thiscol_widest_header > $colwidth} { + set test_width [expr {max($thiscol_widest_header,$colwidth)}] + if {$defmaxw ne ""} { + set test_width [expr {min($colwidth,$defmaxw)}] + } + } + set width_max [expr {max($test_width,$width_max)}] + continue + } + if {$spanc eq "any" || $spanc > 1} { + set spanned [list] ;#spanned is other columns spanned - not including this one + set cnext [expr {$cidx +1}] + set spanlength [lindex $colspans $cnext] + while {$spanlength eq "0" && $cnext < [llength $colspans]} { + lappend spanned $cnext + incr cnext + set spanlength [lindex $colspans $cnext] + } + set others_width 0 + foreach col $spanned { + incr others_width [lindex $configured_widths $col] + if {$showing_vseps} { + incr others_width 1 + } + } + set total_spanned_width [expr {$width_max + $others_width}] + if {$thiscol_widest_header > $total_spanned_width} { + #this just allocates the extra space in the current column - which is not great. + #A proper algorithm for distributing width created by headers to all the spanned columns is needed. + #This is a tricky problem with multiple header lines and arbitrary spans. + #The calculation should probably be done on the table as a whole first and this function should just look up that result. + #Trying to calculate on a specific column only is unlikely to be easy or efficient. + set needed [expr {$thiscol_widest_header - $total_spanned_width}] + #puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)" + if {$defmaxw ne ""} { + set test_width [expr {min($colwidth+$needed,$defmaxw)}] + } else { + set test_width [expr {$colwidth + $needed}] + } + } + } + set width_max [expr {max($test_width,$width_max)}] + } + + #alternative to all the above shennanigans.. let the body cell data determine the size and just wrap the headers + #could also split the needed width amongst the spanned columns? configurable for whether cells expand? + set expand_first_column 1 + if {$expand_first_column} { + set colwidth $width_max + } + + #puts "---column_width $cidx = $colwidth" + return $colwidth + } + method Showing_vseps {} { + #review - show_seps and override mechanism for show_vseps show_hseps - document. + set seps [tcl::dict::get $o_opts_table -show_seps] + set vseps [tcl::dict::get $o_opts_table -show_vseps] + if {$seps eq ""} { + if {$vseps eq "" || $vseps} { + return true + } + } elseif {$seps} { + if {$vseps eq "" || $vseps} { + return true + } + } else { + if {$vseps ne "" && $vseps} { + return true + } + } + return false + } + + method column_datawidth {index_expression args} { + set opts [tcl::dict::create\ + -headers 0\ + -footers 0\ + -colspan unspecified\ + -data 1\ + -cached 1\ + ] + #NOTE: -colspan any is not the same as * + # + #-colspan is relevant to header/footer data only + foreach {k v} $args { + switch -- $k { + -headers - -footers - -colspan - -data - -cached { + tcl::dict::set opts $k $v + } + default { + error "column_datawidth unrecognised flag '$k'. Known flags: [tcl::dict::keys $opts]" + } + } + } + set opt_colspan [tcl::dict::get $opts -colspan] + switch -- $opt_colspan { + * - unspecified {} + any { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0 (use header_colspans_numeric to get actual spans)" + } + default { + if {![string is integer -strict $opt_colspan]} { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0" + } + } + } + + + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + + if {[tcl::dict::get $opts -cached]} { + set hwidest 0 + set bwidest 0 + set fwidest 0 + if {[tcl::dict::get $opts -headers]} { + if {$opt_colspan in {* unspecified}} { + set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + } else { + #this is not cached + # -- --- --- --- + set colheaders [tcl::dict::get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans_numeric] + set hlist [list] + tcl::dict::for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + # -- --- --- --- + } + } + if {[tcl::dict::get $opts -data]} { + set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + } + if {[tcl::dict::get $opts -footers]} { + #TODO! + #set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthfooterseen] + } + return [expr {max($hwidest,$bwidest,$fwidest)}] + } + + #assert cidx is >=0 integer in valid range of keys for o_columndefs + set values [list] + set hwidest 0 + if {[tcl::dict::get $opts -headers]} { + if {$opt_colspan in {* unspecified}} { + lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] + } else { + # -- --- --- --- + set colheaders [tcl::dict::get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans_numeric] + set hlist [list] + tcl::dict::for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + # -- --- --- --- + } + } + if {[tcl::dict::get $opts -data]} { + if {[tcl::dict::exists $o_columndata $cidx]} { + lappend values {*}[tcl::dict::get $o_columndata $cidx] + } + } + if {[tcl::dict::get $opts -footers]} { + lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] + } + if {[llength $values]} { + set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] + set widest [expr {max($valwidest,$hwidest)}] + } else { + set widest $hwidest + } + return $widest + } + #print1 uses basic column joining - useful for testing/debug especially with colspans + method print1 {args} { + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0 } + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set colposn 0 + set numposns [llength $cols] + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + lappend blocks [my get_column_by_index $c {*}$flags] + incr colposn + } + if {[llength $blocks]} { + return [textblock::join -- {*}$blocks] + } else { + return "No columns matched" + } + } + method columncalc_spans {allocmethod} { + set colwidths [tcl::dict::create] ;# to use tcl::dict::incr + set colspace_added [tcl::dict::create] + + set ordered_spans [tcl::dict::create] + tcl::dict::for {col spandata} [my spangroups] { + set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] + set minwidth [tcl::dict::get $o_columndefs $col -minwidth] + set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] + if {$minwidth ne ""} { + if {$dwidth < $minwidth} { + set dwidth $minwidth + } + } + if {$maxwidth ne ""} { + if {$dwidth > $maxwidth} { + set dwidth $maxwidth + } + } + tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered + tcl::dict::set colspace_added $col 0 + + set spanlengths [tcl::dict::get $spandata spanlengths] + foreach slen $spanlengths { + set spans [tcl::dict::get $spandata spangroups $slen] + set spans [lsort -index 7 -integer $spans] + foreach s $spans { + set hwidth [tcl::dict::get $s headerwidth] + set hrow [tcl::dict::get $s hrow] + set scol [tcl::dict::get $s startcol] + tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth + tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth + } + } + } + + #safe jumptable test + #dict for {spanid spandata} $ordered_spans {} + tcl::dict::for {spanid spandata} $ordered_spans { + lassign [split $spanid ,] startcol hrow + set memcols [tcl::dict::get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios + set colids [tcl::dict::keys $memcols] + set hwidth [tcl::dict::get $spandata headerwidth] + set num_cols_spanned [tcl::dict::size $memcols] + if {$num_cols_spanned == 1} { + set col [lindex $memcols 0] + set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] + if {$space_to_alloc > 0} { + set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] + if {$maxwidth ne ""} { + if {$maxwidth > [tcl::dict::get $colwidths $col]} { + set can_alloc [expr {$maxwidth - [tcl::dict::get $colwidths $col]}] + } else { + set can_alloc 0 + } + set will_alloc [expr {min($space_to_alloc,$can_alloc)}] + } else { + set will_alloc $space_to_alloc + } + if {$will_alloc} { + #tcl::dict::set colwidths $col $hwidth + tcl::dict::incr colwidths $col $will_alloc + tcl::dict::set colspace_added $col $will_alloc + } + #log! + #if {$will_alloc < $space_to_alloc} { + # #todo - debug only + # puts stderr "max width $maxwidth hit for col $col - cannot allocate extra [expr {$space_to_alloc - $will_alloc}]" + #} + } + } elseif {$num_cols_spanned > 1} { + set spannedwidth 0 + foreach col $colids { + incr spannedwidth [tcl::dict::get $colwidths $col] + } + set space_to_alloc [expr {$hwidth - $spannedwidth}] + if {[my Showing_vseps]} { + set sepcount [expr {$num_cols_spanned -1}] + incr space_to_alloc -$sepcount + } + #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added + switch -- $allocmethod { + least { + #add to least-expanded each time + #safer than method 1 - pretty balanced + if {$space_to_alloc > 0} { + for {set i 0} {$i < $space_to_alloc} {incr i} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] + foreach testcolid $ordered_all_colids { + if {$testcolid in $colids} { + #assert - we will always find a match + set colid $testcolid + break + } + } + tcl::dict::incr colwidths $colid + tcl::dict::incr colspace_added $colid + } + } + } + least_unmaxed { + #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth + #(we should be able to collapse column width to zero and have header colspans gracefully respond) + #add to least-expanded each time + #safer than method 1 - pretty balanced + if {$space_to_alloc > 0} { + for {set i 0} {$i < $space_to_alloc} {incr i} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] + set colid "" + foreach testcolid $ordered_all_colids { + set maxwidth [tcl::dict::get $o_columndefs $testcolid -maxwidth] + set can_alloc [expr {$maxwidth eq "" || $maxwidth > [tcl::dict::get $colwidths $testcolid]}] + if {$testcolid in $colids} { + if {$can_alloc} { + set colid $testcolid + break + } else { + #remove from future consideration in for loop + #log! + #puts stderr "max width $maxwidth hit for col $testcolid" + tcl::dict::unset colspace_added $testcolid + } + } + } + if {$colid ne ""} { + tcl::dict::incr colwidths $colid + tcl::dict::incr colspace_added $colid + } + } + } + } + all { + #adds space to all columns - not just those spanned - risk of underallocating and truncating some headers! + #probably not a good idea for tables with complex headers and spans + while {$space_to_alloc > 0} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_colids [tcl::dict::keys $ordered_colspace_added] + + foreach col $ordered_colids { + tcl::dict::incr colwidths $col + tcl::dict::incr colspace_added $col + incr space_to_alloc -1 + if {$space_to_alloc == 0} { + break + } + } + } + + } + } + } + } + + set column_widths [tcl::dict::values $colwidths] + #todo - -maxwidth etc + set table_minwidth [tcl::dict::get $o_opts_table -minwidth] ;#min width including frame elements + if {[tcl::string::is integer -strict $table_minwidth]} { + set contentwidth [tcl::mathop::+ {*}$column_widths] + set twidth $contentwidth + if {[my Showing_vseps]} { + incr twidth [llength $column_widths] + incr twidth -1 + } + if {[tcl::dict::get $o_opts_table -show_edge]} { + incr twidth 2 + } + # + set shortfall [expr {$table_minwidth - $twidth}] + if {$shortfall > 0} { + set space_to_alloc $shortfall + while {$space_to_alloc > 0} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_colids [tcl::dict::keys $ordered_colspace_added] + + foreach col $ordered_colids { + tcl::dict::incr colwidths $col + tcl::dict::incr colspace_added $col + incr space_to_alloc -1 + if {$space_to_alloc == 0} { + break + } + } + } + set column_widths [tcl::dict::values $colwidths] + } + + } + + return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] + } + + #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 + foreach c [tcl::dict::keys $o_columndefs] { + tcl::dict::set spangroups $c [list spanlengths {}] + set spanlist [my column_get_spaninfo $c] + set index_spanlen_val 5 + set spanlist [lsort -index $index_spanlen_val -integer $spanlist] + set ungrouped $spanlist + + while {[llength $ungrouped]} { + set spanlen [lindex $ungrouped 0 $index_spanlen_val] + set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen] + set sgroup [list] + foreach p $spangroup_posns { + set spaninfo [lindex $ungrouped $p] + set hcol [tcl::dict::get $spaninfo startcol] + set hrow [tcl::dict::get $spaninfo hrow] + set header [lindex [tcl::dict::get $o_columndefs $hcol -headers] $hrow] + if {[tcl::dict::exists $headerwidths $hcol,$hrow]} { + set hwidth [tcl::dict::get $headerwidths $hcol,$hrow] + } else { + set hwidth [textblock::width $header] + tcl::dict::set headerwidths $hcol,$hrow $hwidth + } + lappend spaninfo headerwidth $hwidth + lappend sgroup $spaninfo + } + set spanlengths [tcl::dict::get $spangroups $c spanlengths] + lappend spanlengths $spanlen + tcl::dict::set spangroups $c spanlengths $spanlengths + tcl::dict::set spangroups $c spangroups $spanlen $sgroup + set ungrouped [lremove $ungrouped {*}$spangroup_posns] + } + } + return $spangroups + } + method column_get_own_spans {cidx} { + set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] + } + method column_get_spaninfo {cidx} { + set spans_by_header [my header_colspans] + set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] + set spaninfo [list] + set numcols [tcl::dict::size $o_columndefs] + #note that 'any' can occur in positions other than column 0 - meaning any remaining until next non-zero span + tcl::dict::for {hrow rawspans} $spans_by_header { + set thiscol_spanval [lindex $rawspans $cidx] + if {$thiscol_spanval eq "any" || $thiscol_spanval > 0} { + set spanstartcol $cidx ;#own column + if {$thiscol_spanval eq "any"} { + #scan right to first non-zero to get actual length of 'any' span + #REVIEW! + set spanlen 1 + for {set i [expr {$cidx+1}]} {$i < $numcols} {incr i} { + #abort at next any or number or empty string + if {[lindex $rawspans $i] ne "0"} { + break + } + incr spanlen + } + #set spanlen [expr {$numcols - $cidx}] + } else { + set spanlen $thiscol_spanval + } + } else { + #look left til we see an any or a non-zero value + for {set i $cidx} {$i > -1} {incr i -1} { + set s [lindex $rawspans $i] + if {$s eq "any" || $s > 0} { + set spanstartcol $i + if {$s eq "any"} { + #REVIEW! + #set spanlen [expr {$numcols - $i}] + set spanlen 1 + #now scan right to see how long the 'any' actually is + for {set j [expr {$i+1}]} {$j < $numcols} {incr j} { + if {[lindex $rawspans $j] ne "0"} { + break + } + incr spanlen + } + } else { + set spanlen $s + } + break + } + } + } + #assert - we should always find 1 answer for each header row + lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen] + } + return $spaninfo + } + method calculate_column_widths {args} { + set column_count [tcl::dict::size $o_columndefs] + + set opts [tcl::dict::create\ + -algorithm $o_column_width_algorithm\ + ] + foreach {k v} $args { + switch -- $k { + -algorithm { + tcl::dict::set opts $k $v + } + default { + error "Unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + set opt_algorithm [tcl::dict::get $opts -algorithm] + #puts stderr "--- recalculating column widths -algorithm $opt_algorithm" + set known_algorithms [list basic simplistic span span2] + switch -- $opt_algorithm { + basic { + #basic column by column - This allocates extra space to first span/column as they're encountered. + #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans + #The header values can extend over some of the spanned columns - but not optimally so. + set o_calculated_column_widths [list] + for {set c 0} {$c < $column_count} {incr c} { + lappend o_calculated_column_widths [my basic_column_width $c] + } + } + simplistic { + #just uses the widest column data or header element. + #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column + #This is a conservative option potentially useful in testing/debugging. + set o_calculated_column_widths [list] + for {set c 0} {$c < $column_count} {incr c} { + lappend o_calculated_column_widths [my column_width_configured $c] + } + } + span { + #widest of smallest spans first method + #set calcresult [my columncalc_spans least] + set calcresult [my columncalc_spans least_unmaxed] + set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] + } + span2 { + #allocates more evenly - but truncates headers sometimes + set calcresult [my columncalc_spans all] + set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] + } + default { + error "calculate_column_widths unknown algorithm $opt_algorithm. Known algorithms: $known_algorithms" + } + } + #remember the last algorithm used + set o_column_width_algorithm $opt_algorithm + return $o_calculated_column_widths + } + method print2 {args} { + variable full_column_cache + set full_column_cache [tcl::dict::create] + + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set colposn 0 + set numposns [llength $cols] + set padwidth 0 + set table "" + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + #lappend blocks [my get_column_by_index $c {*}$flags] + #todo - only check and store in cache if table has header or footer colspans > 1 + if {[tcl::dict::exists $full_column_cache $c]} { + #puts "!!print used full_column_cache for $c" + set columninfo [tcl::dict::get $full_column_cache $c] + } else { + set columninfo [my get_column_by_index $c -return dict {*}$flags] + tcl::dict::set full_column_cache $c $columninfo + } + set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] + set bodywidth [tcl::dict::get $columninfo bodywidth] + + if {$table eq ""} { + set table $nextcol + set height [textblock::height $table] ;#only need to get height once at start + } else { + set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] + set table [overtype::renderspace -expand_right 1 -transparent $TSUB $table[unset table] $nextcol] + #JMN + + #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] + #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] + } + incr padwidth $bodywidth + incr colposn + } + + if {[llength $cols]} { + #return [textblock::join -- {*}$blocks] + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + + # using -startcolumn to do slightly less work + method print3 {args} { + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set numposns [llength $cols] + set colposn 0 + set padwidth 0 + set table "" + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + set columninfo [my get_column_by_index $c -return dict {*}$flags] + set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] + set bodywidth [tcl::dict::get $columninfo bodywidth] + + if {$table eq ""} { + set table $nextcol + set height [textblock::height $table] ;#only need to get height once at start + } else { + set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] + } + incr padwidth $bodywidth + incr colposn + } + + if {[llength $cols]} { + #return [textblock::join -- {*}$blocks] + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + + #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 { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set numposns [llength $cols] + set colposn 0 + set padwidth 0 + set header_build "" + set body_blocks [list] + set headerheight 0 + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + set columninfo [my get_column_by_index $c -return dict {*}$flags] + #set nextcol [tcl::dict::get $columninfo column] + set bodywidth [tcl::dict::get $columninfo bodywidth] + set headerheight [tcl::dict::get $columninfo headerheight] + #set nextcol_lines [split $nextcol \n] + #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] + #set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n] + set nextcol_header [tcl::dict::get $columninfo header] + set nextcol_body [tcl::dict::get $columninfo body] + + if {$header_build eq "" && ![llength $body_blocks]} { + set header_build $nextcol_header + } else { + if {$headerheight > 0} { + set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] + } + #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] + } + lappend body_blocks $nextcol_body + incr padwidth $bodywidth + incr colposn + } + if {![llength $body_blocks]} { + set body_build "" + } else { + #body blocks should not be ragged - so can use join_basic + set body_build [textblock::join_basic -- {*}$body_blocks] + } + if {$headerheight > 0} { + set table [tcl::string::cat $header_build \n $body_build] + } else { + set table $body_build + } + + if {[llength $cols]} { + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + 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 + } + + #*** !doctools + #[list_end] + }] + #*** !doctools + # [list_end] [comment {- end enumeration provider_classes }] + #[list_end] [comment {- end itemized list textblock::class groupings -}] + } + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# +#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 *} + tcl::namespace::import ::term::ansi::code::macros::cd::* + tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} + } + proc spantest {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2] + $t configure_column 0 -header_colspans {3 4 5 any 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + proc spantest1 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers [list "span3-any longer than other span any" "1-span4\n2-span4 second line" "span-any short aligned?" "span5/5 longest etc blah 123" span2] + $t configure_column 0 -header_colspans {any 4 any 5 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 0 0 0} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + $t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs) + return $t + } + + #more complex colspans + proc spantest2 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} + $t configure_column 0 -header_colspans {3 4 1 any 2} + $t configure_column 1 -header_colspans {0 0 2 0 0} + $t configure_column 2 -headers {"" "" "" "" c2span2} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 2 0 0} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + proc spantest3 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1} + $t configure_column 0 -header_colspans {3 4 1 any 2 1} + $t configure_column 1 -header_colspans {0 0 4 0 0 1} + $t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"} + $t configure_column 2 -headers {"" "" "" "" "" c2span2} + $t configure_column 2 -header_colspans {0 0 0 0 1 2} + $t configure_column 4 -headers {"4" "444" "" "" "" "44"} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + + punk::args::define { + @id -id ::textblock::periodic + @cmd -name textblock::periodic -help "A rudimentary periodic table + This is primarily a test of textblock::class::table" + + -return -default table\ + -choices {table tableobject}\ + -help "default choice 'table' returns the displayable table output" + -compact -default 1 -type boolean -help "compact true defaults: -show_vseps 0 -show_header 0 -show_edge 0" + -frame -default 1 -type boolean + -show_vseps -default "" -type boolean + -show_header -default "" -type boolean + -show_edge -default "" -type boolean + -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" + @values -min 0 -max 0 + } + + proc periodic {args} { + #For an impressive interactive terminal app (javascript) + # see: https://github.com/spirometaxas/periodic-table-cli + set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + set opt_return [tcl::dict::get $opts -return] + if {[tcl::dict::get $opts -forcecolour]} { + set fc forcecolour + } else { + set fc "" + } + + #examples ptable.com + set elements [list\ + 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ + 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ + 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ + 4 K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr\ + 5 Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe\ + 6 Cs Ba "" Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn\ + 7 Fr Ra "" Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og\ + " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ + "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ + "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ + ] + + set type_colours [list] + + set ecat [tcl::dict::create] + + set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] + set ansi [a+ {*}$fc web-black Web-gold] + set val [list ansi $ansi cat alkaline_earth] + foreach e $cat_alkaline_earth { + tcl::dict::set ecat $e $val + } + + set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] + #set ansi [a+ {*}$fc web-black Web-lightgreen] + set ansi [a+ {*}$fc black Term-113] + set val [list ansi $ansi cat reactive_nonmetal] + foreach e $cat_reactive_nonmetal { + tcl::dict::set ecat $e $val + } + + set cat [list Li Na K Rb Cs Fr] + #set ansi [a+ {*}$fc web-black Web-Khaki] + set ansi [a+ {*}$fc black Term-lightgoldenrod2] + set val [list ansi $ansi cat alkali_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] + #set ansi [a+ {*}$fc web-black Web-lightsalmon] + set ansi [a+ {*}$fc black Term-orange1] + set val [list ansi $ansi cat transition_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Al Ga In Sn Tl Pb Bi Po] + set ansi [a+ {*}$fc web-black Web-lightskyblue] + set val [list ansi $ansi cat post_transition_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list B Si Ge As Sb Te At] + #set ansi [a+ {*}$fc web-black Web-turquoise] + set ansi [a+ {*}$fc black Brightcyan] + set val [list ansi $ansi cat metalloids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list He Ne Ar Kr Xe Rn] + set ansi [a+ {*}$fc web-black Web-orchid] + set val [list ansi $ansi cat noble_gases] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] + set ansi [a+ {*}$fc web-black Web-plum] + set val [list ansi $ansi cat actinoids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] + #set ansi [a+ {*}$fc web-black Web-tan] + set ansi [a+ {*}$fc black Term-tan] + set val [list ansi $ansi cat lanthanoids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set ansi [a+ {*}$fc web-black Web-whitesmoke] + set val [list ansi $ansi cat other] + foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { + tcl::dict::set ecat $e $val + } + + set elements1 [list] + set RST [a+] + foreach e $elements { + if {[tcl::dict::exists $ecat $e]} { + set ansi [tcl::dict::get $ecat $e ansi] + #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] + #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway + lappend elements1 $ansi$e + } else { + lappend elements1 $e + } + } + + set t [list_as_table -columns 19 -return tableobject $elements1] + #(defaults to show_hseps 0) + + #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options + + set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] + set c 0 + foreach h $header_0 { + $t configure_column $c -headers [list $h] -minwidth 2 + incr c + } + set ccount [$t column_count] + for {set c 0} {$c < $ccount} {incr c} { + $t configure_column $c -minwidth 3 + } + if {[tcl::dict::get $opts -compact]} { + #compact defaults - but let explicit arguments override + set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0] + } else { + set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1] + } + dict for {k v} $conf { + if {[dict get $opts $k] ne ""} { + dict set conf $k [dict get $opts $k] + } + } + + set moreopts [dict create\ + -frametype_header light\ + -ansiborder_header [a+ {*}$fc brightwhite]\ + -ansibase_header [a+ {*}$fc Black]\ + -ansibase_body [a+ {*}$fc Black]\ + -ansiborder_body [a+ {*}$fc black]\ + -frametype block + ] + $t configure {*}[dict merge $conf $moreopts] + + #-ansiborder_header [a+ {*}$fc web-white]\ + + if {$opt_return eq "table"} { + 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 -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + } else { + set output [$t print] + } + $t destroy + return $output + } + return $t + } + + proc bookend_lines {block start {end "\x1b\[m"}} { + set out "" + foreach ln [split $block \n] { + append out $start $ln $end \n + } + return [string range $out 0 end-1] + } + proc ansibase_lines {block {newprefix ""}} { + set base "" + set out "" + if {$newprefix eq ""} { + if {![punk::ansi::ta::detect $block]} { + return $block + } + foreach ln [split $block \n] { + set parts [punk::ansi::ta::split_codes $ln] + if {[lindex $parts 0] eq ""} { + if {[lindex $parts 1] ne "" && ![punk::ansi::codetype::is_sgr_reset [lindex $parts 1]]} { + set base [lindex $parts 1] + append out $base + } else { + append out $base + } + } else { + #leading plaintext - maintain our base + append out $base [lindex $parts 0] [lindex $parts 1] + } + + set code_idx 3 + foreach {pt code} [lrange $parts 2 end] { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set parts [linsert $parts $code_idx+1 $base] + } + incr code_idx 2 + } + append out {*}[lrange $parts 2 end] \n + } + return [string range $out 0 end-1] + } else { + set base $newprefix + if {![punk::ansi::ta::detect $block]} { + foreach ln [split $block \n] { + append out $base $ln \n + } + return $out + } + foreach ln [split $block \n] { + set parts [punk::ansi::ta::split_codes $ln] + set code_idx 1 + set offset 0 + foreach {pt code} $parts { + if {$code_idx == 1} { + #first pt & code + if {$pt ne ""} { + #leading plaintext + set parts [linsert $parts 0 $base] + incr offset + } + } + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set parts [linsert $parts [expr {$code_idx+1+$offset}] $base] + incr offset + } + incr code_idx 2 + } + append out {*}$parts \n + } + return [string range $out 0 end-1] + } + } + + set FRAMETYPES [textblock::frametypes] + punk::args::define [punk::lib::tstr -return string { + @id -id ::textblock::list_as_table + @cmd -name "textblock::list_as_table" -help\ + "Display a list in a bordered 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 "Each supplied -header argument is a header row. + The number of values for each must be <= number of columns" + -show_header -type boolean\ + -help "Whether to show a header row. + Omit 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 + Will default to 2 if not using an existing -table object" + + @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_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 count [llength $datalist] + + set is_new_table 0 + if {$existing_table ne ""} { + if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} { + error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])" + } + set t $existing_table + foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} { + if {[tcl::dict::get $opts $prop] ne ""} { + $t configure $prop [tcl::dict::get $opts $prop] + } + } + if {[dict get $opts -action] eq "replace"} { + $t row_clear + } + set cols [$t column_count] + if {[tcl::string::is integer -strict $opt_columns]} { + if {$opt_columns > $cols} { + set extra [expr {$opt_columns - $cols}] + for {set c 0} {$c < $extra} {incr c} { + $t add_column + } + } elseif {$opt_columns < $cols} { + #todo - auto add blank values in the datalist + error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported" + } + set cols [$t column_count] + } + } else { + set is_new_table 1 + set colheaders {} + if {[tcl::dict::get $opts -colheaders] ne ""} { + set colheaders [dict get $opts -colheaders] + } else { + set colheaders [list] + } + set r 0 + foreach ch $colheaders { + set rows [llength $ch] + if {$r < $rows} { + set r $rows + } + } + if {[llength [tcl::dict::get $opts -header]]} { + foreach hrow [tcl::dict::get $opts -header] { + set c 0 + foreach cell $hrow { + if {[llength $colheaders] < $c+1} { + lappend colheaders [lrepeat $r {}] + } + set colinfo [lindex $colheaders $c] + if {$r > [llength $colinfo]} { + set diff [expr {$r - [llength $colinfo]}] + lappend colinfo {*}[lrepeat $diff {}] + } + lappend colinfo $cell + lset colheaders $c $colinfo + incr c + } + incr r + } + } + + + if {[llength $colheaders] > 0} { + if {![tcl::dict::exists $opts received -show_header]} { + set show_header 1 + } else { + set show_header [tcl::dict::get $opts -show_header] + } + } else { + if {![tcl::dict::exists $opts received -show_header]} { + set show_header 0 + } else { + set show_header [tcl::dict::get $opts -show_header] + } + } + + if {[tcl::string::is integer -strict $opt_columns]} { + set cols $opt_columns + if {[llength $colheaders] && $cols != [llength $colheaders]} { + error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $colheaders])" + } + } else { + #review + if {[llength $colheaders]} { + set cols [llength $colheaders] + } else { + set cols 2 ;#seems a reasonable default + } + } + #defaults for new table only + #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_vseps] eq ""} { + tcl::dict::set opts -show_vseps 1 + } + if {[tcl::dict::get $opts -show_hseps] eq ""} { + tcl::dict::set opts -show_hseps 0 + } + + set t [textblock::class::table new\ + -show_header $show_header\ + -show_edge [tcl::dict::get $opts -show_edge]\ + -frametype [tcl::dict::get $opts -frametype]\ + -show_seps [tcl::dict::get $opts -show_seps]\ + -show_vseps [tcl::dict::get $opts -show_vseps]\ + -show_hseps [tcl::dict::get $opts -show_hseps]\ + ] + if {[llength $colheaders]} { + for {set c 0} {$c < $cols} {incr c} { + $t add_column -headers [lindex $colheaders $c] + } + } else { + for {set c 0} {$c < $cols} {incr c} { + $t add_column -headers [list $c] + } + } + } + + set full_rows [expr {$count / $cols}] + set last_items [expr {$count % $cols}] + + + set rowdata [list] + set row [list] + set i 0 + if {$full_rows > 0} { + for {set r 0} {$r < $full_rows} {incr r} { + set j [expr {$i + ($cols -1)}] + set row [lrange $datalist $i $j] + incr i $cols + lappend rowdata $row + } + } + if {$last_items > 0} { + set idx [expr {$last_items -1}] + lappend rowdata [lrange $datalist end-$idx end] + } + foreach row $rowdata { + set shortfall [expr {$cols - [llength $row]}] + if {$shortfall > 0} { + #set row [concat $row [lrepeat $shortfall ""]] + lappend row {*}[lrepeat $shortfall ""] + } + $t add_row $row + } + #puts stdout $rowdata + if {[tcl::dict::get $opts -return] eq "table"} { + set result [$t print] + if {$is_new_table} { + $t destroy + } + return $result + } else { + return $t + } + } + #return a homogenous block of characters - ie lines all same length, all same character + #printing-width in terminal columns is not necessarily same as blockwidth even if a single char is passed (could be full-width unicode character) + #This can have ansi SGR codes - but to repeat blocks containing ansi-movements, the block should first be rendered to a static output with something like overtype::left + proc block {blockwidth blockheight {char " "}} { + if {$blockwidth < 0} { + error "textblock::block blockwidth must be an integer greater than or equal to zero" + } + if {$blockheight <= 0} { + error "textblock::block blockheight must be a positive integer" + } + if {$char eq ""} {return ""} + #using tcl::string::length is ok + if {[tcl::string::length $char] == 1} { + set row [tcl::string::repeat $char $blockwidth] + set mtrx [lrepeat $blockheight $row] + return [::join $mtrx \n] + } else { + set charblock [tcl::string::map [list \r\n \n] $char] + if {[tcl::string::last \n $charblock] >= 0} { + if {$blockwidth > 1} { + #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) + set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] + } else { + set row $charblock + } + } else { + set row [tcl::string::repeat $char $blockwidth] + } + set mtrx [lrepeat $blockheight $row] + return [::join $mtrx \n] + } + } + + + punk::args::define { + @id -id ::textblock::testblock + @cmd -name textblock::testblock -help\ + "Create a block of characters size + columns wide and size rows tall. + (which on a terminal will show as a + vertically oriented rectangle due to + cells being taller than their width) + + The characters used are + 123456789ABCDEF + " + -size -type integer\ + -default 15\ + -optional 1\ + -range {1 15} + -direction -default horizontal\ + -choices {horizontal vertical}\ + -help\ + "When rainbow is in the colour list, + this also affects the direction of + colour changes" + @values -min 0 -max 2 + colour -type list -default {} -optional 1 -help\ + "List of Ansi colour names + e.g. testblock 10 {white Red} + produces a block of character 10x10 + with white text on red bacground + + The additional pseudo-color 'rainbow' + is available. + " + } + + proc testblock {args} { + set argd [punk::args::get_by_id ::textblock::testblock $args] + set colour [dict get $argd values colour] + set size [dict get $argd opts -size] + + set rainbow_list [list] + lappend rainbow_list {30 47} ;#black White + lappend rainbow_list {31 46} ;#red Cyan + lappend rainbow_list {32 45} ;#green Purple + lappend rainbow_list {33 44} ;#yellow Blue + lappend rainbow_list {34 43} ;#blue Yellow + lappend rainbow_list {35 42} ;#purple Green + lappend rainbow_list {36 41} ;#cyan Red + lappend rainbow_list {37 40} ;#white Black + lappend rainbow_list {black Yellow} + lappend rainbow_list red + lappend rainbow_list green + lappend rainbow_list yellow + lappend rainbow_list blue + lappend rainbow_list purple + lappend rainbow_list cyan + lappend rainbow_list {white Red} + + #set rainbow_direction "horizontal" + #set vpos [lsearch $colour vertical] + #if {$vpos >= 0} { + # set rainbow_direction vertical + # set colour [lremove $colour $vpos] + #} + #set hpos [lsearch $colour horizontal] + #if {$hpos >=0} { + # #horizontal is the default and superfluous but allowed for symmetry + # set colour [lremove $colour $hpos] + #} + set direction [dict get $argd opts -direction] + + + + 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 "" + } else { + set RST [a] + } + if {"rainbow" in $colour && $direction eq "vertical"} { + #column first - colour change each column + set c [::join $charsubset \n] + + set clist [list] + for {set i 0} {$i <$size} {incr i} { + set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] + set ansi [a+ {*}$colour2] + + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] + lappend clist ${ansicode}$c$RST + } + if {"noreset" in $colour} { + return [textblock::join_basic -ansiresets 0 -- {*}$clist] + } else { + return [textblock::join_basic -- {*}$clist] + } + } elseif {"rainbow" in $colour} { + #direction must be horizontal + set block "" + for {set r 0} {$r < $size} {incr r} { + set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] + set ansi [a+ {*}$colour2] + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] + set row "$ansicode" + foreach c $charsubset { + append row $c + } + append row $RST + append block $row\n + } + set block [tcl::string::trimright $block \n] + return $block + } else { + #row first - + set rows [list] + foreach ch $charsubset { + lappend rows [tcl::string::repeat $ch $size] + } + set block [::join $rows \n] + if {$colour ne ""} { + set block [a+ {*}$colour]$block$RST + } + return $block + } + } + interp alias {} testblock {} textblock::testblock + + #todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table + proc width {textblock} { + #backspaces, vertical tabs ? + if {$textblock eq ""} { + return 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 {[string length $textblock] > 1 && [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}]] + } + 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 {[string length $textblock] > 1 && [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] + if {$firstnl >= 0} { + set tl [tcl::string::range $textblock 0 $firstnl] + } else { + set tl $textblock + } + if {[punk::ansi::ta::detect $tl]} { + set tl [punk::ansi::ansistripraw $tl] + } + return [punk::char::ansifreestring_width $tl] + } + #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. + proc string_length_line_max {textblock} { + #tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + set max 0 + foreach ln [split $textblock \n] { + if {[tcl::string::length $ln] > $max} {set max [tcl::string::length $ln]} + } + return $max + } + #*slightly* slower + #proc string_length_line_max {textblock} { + # tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + #} + proc string_length_line_min textblock { + tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + } + + proc height {textblock} { + #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le + #empty string still has height 1 (at least for left-right/right-left languages) + + #vertical tab on a proper terminal should move directly down. + #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) + + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + } + #MAINTENANCE - same as overtype::blocksize? + proc size {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack + 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] + } + #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests + if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] + set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + } else { + set width [punk::char::ansifreestring_width $textblock] + } + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height + } + proc size2 {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack + 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] + } + #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests + if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] + set lines [split $textblock \n] + set num_le [expr {[llength $lines]-1}] + #set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]] + set width 0 + foreach ln $lines { + set w [::punk::char::ansifreestring_width $ln] + if {$w > $width} { + set width $w + } + } + } else { + set num_le 0 + set width [punk::char::ansifreestring_width $textblock] + } + #set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height + } + proc size_as_opts {textblock} { + set sz [size $textblock] + return [dict create -width [dict get $sz width] -height [dict get $sz height]] + } + proc size_as_list {textblock} { + set sz [size $textblock] + return [list [dict get $sz width] [dict get $sz height]] + } + #must be able to handle block as string with or without newlines + #if no newlines - attempt to treat as a list + #must handle whitespace-only string,list elements, and/or lines. + #reviewing 2024 - this seems like too much magic! + proc width1 {block} { + if {$block eq ""} { + return 0 + } + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set block [textutil::tabify::untabify2 $block $tw] + if {[tcl::string::last \n $block] >= 0} { + return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]] + } + if {[catch {llength $block}]} { + return [::punk::char::string_width [ansistrip $block]] + } + if {[llength $block] == 0} { + #could be just a whitespace string + return [tcl::string::length $block] + } + return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]] + } + + #we shouldn't make textblock depend on the punk pipeline system + #pipealias ::textblock::padleft .= {list $input [tcl::string::repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" + foreach {k v} $args { + switch -- $k { + -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { + tcl::dict::set opts $k $v + } + default { + error "textblock::pad unrecognised option '$k'. Usage: $usage" + } + } + } + # -- --- --- --- --- --- --- --- --- --- + set padchar [tcl::dict::get $opts -padchar] + #if padchar width (screen width) > 1 - length calculations will not be correct + #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map + #The caller may also use ansi within the padchar - although it's unlikely to be efficient. + # -- --- --- --- --- --- --- --- --- --- + set known_whiches [list l left r right c center centre] + set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] + switch -- $opt_which { + center - centre - c { + set which c + } + left - l { + set which l + } + right - r { + set which r + } + default { + error "textblock::pad unrecognised value for -which option. Known values $known_whiches" + } + } + # -- --- --- --- --- --- --- --- --- --- + set opt_width [tcl::dict::get $opts -width] + switch -- $opt_width { + "" - auto { + set width auto + } + default { + if {![tcl::string::is integer -strict $opt_width] || $opt_width < 0} { + error "textblock::pad -width must be an integer >=0" + } + set width $opt_width + } + } + # -- --- --- --- --- --- --- --- --- --- + set opt_withinansi [tcl::dict::get $opts -within_ansi] + switch -- $opt_withinansi { + 0 - 1 {} + default { + set opt_withinansi 2 + } + } + # -- --- --- --- --- --- --- --- --- --- + 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"} { + #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] + + set padcharsize [punk::ansi::printing_length $padchar] + set pad_has_ansi [punk::ansi::ta::detect $padchar] + if {$block eq ""} { + #we need to treat as a line + set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + #TODO + #review - what happens when padchar has ansi, or the width would split a double-wide unicode char? + #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) + #we should use overtype with suitable replacement char (space?) for chopped double-wides + if {!$pad_has_ansi} { + return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] + } else { + set base [tcl::string::repeat " " $width] + return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + } + + #review - tcl format can only pad with zeros or spaces? + #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 + #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 + + 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 + foreach {pt ansi} $parts { + if {$pt ne ""} { + set has_nl [expr {[tcl::string::last \n $pt]>=0}] + if {$has_nl} { + set pt [tcl::string::map [list \r\n \n] $pt] + set partlines [split $pt \n] + } else { + set partlines [list $pt] + } + set last [expr {[llength $partlines]-1}] + set p 0 + foreach pl $partlines { + lappend line_chunks $pl + #incr line_len [punk::char::ansifreestring_width $pl] + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + } + if {$p != $last} { + #do padding + 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 + + #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars + if {[tcl::dict::exists $pad_cache $missing]} { + set pad [tcl::dict::get $pad_cache $missing] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + dict set pad_cache $missing $pad + } + switch -- $which-$opt_withinansi { + r-0 { + lappend line_chunks $pad + } + r-1 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + } + r-2 { + lappend line_chunks $pad + } + l-0 { + set line_chunks [linsert $line_chunks 0 $pad] + } + l-1 { + if {[lindex $line_chunks 0] eq ""} { + set line_chunks [linsert $line_chunks 2 $pad] + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + l-2 { + if {$lnum == 0} { + if {[lindex $line_chunks 0] eq ""} { + set line_chunks [linsert $line_chunks 2 $pad] + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + } + } + lappend lines [::join $line_chunks ""] + set line_chunks [list] + set line_len 0 + incr lnum + } + incr p + } + } else { + #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes + lappend line_chunks "" + } + #don't let trailing empty ansi affect the line_chunks length + if {$ansi ne ""} { + lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? + } + } + #pad last line + 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] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + } + #set pad [tcl::string::repeat $padchar $missing] + switch -- $which-$opt_withinansi { + r-0 { + lappend line_chunks $pad + } + r-1 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + } + r-2 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + #lappend line_chunks $pad + } + l-0 { + #if {[lindex $line_chunks 0] eq ""} { + # set line_chunks [linsert $line_chunks 2 $pad] + #} else { + # set line_chunks [linsert $line_chunks 0 $pad] + #} + set line_chunks [linsert $line_chunks 0 $pad] + } + l-1 { + #set line_chunks [linsert $line_chunks 0 $pad] + set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] + } + l-2 { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + } + lappend lines [::join $line_chunks ""] + return [::join $lines \n] + } + + #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single + #resulting list is no longer a valid ansisplit list + proc _insert_before_text_or_last_ansi {str ansisplits} { + if {[llength $ansisplits] == 1} { + #ansisplits was a split on plaintext only + return [list $str [lindex $ansisplits 0]] + } elseif {[llength $ansisplits] == 0} { + return [list $str] + } + if {[llength $ansisplits] %2 != 1} { + error "_insert_before_text_or_last_ansi ansisplits list is not a valid resultlist from an ansi split - must be odd number of elements pt,ansi,pt,ansi...pt" + } + set out [list] + set i 0 + set i_last_code [expr {[llength $ansisplits]-3}] ;#would normally be -2 - but our i is jumping to each pt - not every element + foreach {pt code} $ansisplits { + if {$pt ne ""} { + return [lappend out $str {*}[lrange $ansisplits $i end]] + } + if {$i == $i_last_code} { + return [lappend out $str {*}[lrange $ansisplits $i end]] + } + #code being empty can only occur when we have reached last pt + #we have returned by then. + lappend out $code + incr i 2 + } + error "_insert_before_text_or_last_ansi failed on input str:[ansistring VIEW $str] ansisplits:[ansistring VIEW $ansisplits]" + } + proc pad_test {block} { + set width [textblock::width $block] + set padtowidth [expr {$width + 10}] + 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] + + set t [textblock::list_as_table -columns 3 -return tableobject $testlist] + $t configure_column 0 -headers [list "ansi"] + $t configure_column 1 -headers [list "Left"] + $t configure_column 2 -headers [list "Right"] + $t configure -show_header 1 + puts stdout [$t print] + return $t + } + + proc pad_test_blocklist {blocklist args} { + set opts [tcl::dict::create\ + -description ""\ + -blockheaders ""\ + ] + foreach {k v} $args { + switch -- $k { + -description - -blockheaders { + tcl::dict::set opts $k $v + } + default { + error "pad_test_blocklist unrecognised option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + set opt_blockheaders [tcl::dict::get $opts -blockheaders] + set bheaders [tcl::dict::create] + if {$opt_blockheaders ne ""} { + set b 0 + foreach h $opt_blockheaders { + if {$b < [llength $blocklist]} { + tcl::dict::set bheaders $b $h + } + incr b + } + } + + set b 0 + set blockinfo [tcl::dict::create] + foreach block $blocklist { + set width [textblock::width $block] + tcl::dict::set blockinfo $b width $width + set padtowidth [expr {$width + 3}] + tcl::dict::set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] + tcl::dict::set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] + tcl::dict::set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] + tcl::dict::set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] + tcl::dict::set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] + tcl::dict::set blockinfo $b right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] + incr b + } + + set r0 [list "0"] + set r1 [list "1"] + set r2 [list "2"] + set r3 [list "column\ncolours"] + + #1 + #test without table padding + #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering + #(basically a mechanism to add extra resets at start and end of each line) + #dict for {b bdict} $blockinfo { + # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] + # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] + # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] + #} + + #2 - the more useful one? + tcl::dict::for {b bdict} $blockinfo { + lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] + lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] + lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] + lappend r3 "" "" + } + + set rows [concat $r0 $r1 $r2 $r3] + + set column_ansi [a+ web-white Web-Gray] + + set t [textblock::list_as_table -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows] + $t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi + set col 1 + tcl::dict::for {b bdict} $blockinfo { + if {[tcl::dict::exists $bheaders $b]} { + set hdr [tcl::dict::get $bheaders $b] + } else { + set hdr "Block $b" + } + $t configure_column $col -headers [list $hdr "Left"] -minwidth [expr {$padtowidth + 2}] + $t configure_column $col -header_colspans 2 -ansibase $column_ansi + incr col + $t configure_column $col -headers [list "-" "Right"] -minwidth [expr {$padtowidth + 2}] -ansibase $column_ansi + incr col + } + $t configure -show_header 1 + puts stdout [$t print] + return $t + } + proc pad_example {} { + set headers [list] + set blocks [list] + + lappend blocks "[textblock::testblock 4 rainbow]" + lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" + + lappend blocks "[textblock::testblock 4 rainbow][a]" + lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" + + lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" + lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}]" + lappend headers "rainbow 4x4\nno line resets\nnothing trailing" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" + lappend headers "rainbow 4x4\nno line resets\ntrailing reset" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" + lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" + + set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] + } + proc pad_example2 {} { + set headers [list] + set blocks [list] + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" + + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" + + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" + + set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] + } + + + #playing with syntax + + # pipealias ::textblock::join_width .= {list $lhs [tcl::string::repeat " " $w1] $rhs [tcl::string::repeat " " $w2]} {| + # /2,col1/1,col2/3 + # >} punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| + # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| + # >} punk::lib::list_as_lines -- $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} { + #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. + # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner + #" + 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 + } + set idx 0 + set fordata [list] + set colindices [list] + foreach b $blocks { + if {[punk::ansi::ta::detect $b]} { + lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] + } else { + lappend fordata "v($idx)" [split $b \n] + } + lappend colindices $idx + incr idx + } + set outlines [list] + foreach {*}$fordata { + set row {} + foreach colidx $colindices { + lappend row $v($colidx) + } + lappend outlines [::join $row ""] + } + return [::join $outlines \n] + } + #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed + #they may however still be 'ragged' ie differing line lengths + proc ::textblock::join {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 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] + 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] + } 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 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 " "] + } + lappend outlines $row + } + #puts stderr "--->outlines len: [llength $outlines]" + return [::join $outlines \n] + } + + proc ::textblock::trim {block} { + error "textblock::trim unimplemented" + set trimlines "" + } + + #pipealias ::textblock::join_right .= {list $lhs [tcl::string::repeat " " [width $lhs]] $rhs [tcl::string::repeat " " [width $rhs]]} {| + # /2,col1/1,col2/3 + # >} .=> punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| + # >} punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] + set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] + set testblock [textblock::testblock 15 rainbow] + set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] + set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] + } + + + proc example {args} { + set opts [tcl::dict::create -forcecolour 0] + foreach {k v} $args { + switch -- $k { + -forcecolour { + tcl::dict::set opts $k $v + } + default { + error "textblock::example unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]" + } + } + } + set opt_forcecolour 0 + if {[tcl::dict::get $opts -forcecolour]} { + set fc forcecolour + set opt_forcecolour 1 + } else { + set fc "" + } + set pleft [>punk . rhs] + set pright [>punk . lhs] + set prightair [>punk . lhs_air] + set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] + set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] + set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] + set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] + set RST [a] + set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] + set punks [textblock::join -- $pleft $pright] + set pleft_greenb $greenb$pleft$RST + set pright_redb $redb$pright$RST + set prightair_cyanb $cyanb$prightair$RST + set cpunks [textblock::join -- $pleft_greenb $pright_redb] + set out "" + append out $punks \n + append out $cpunks \n + append out [textblock::join -- $punks $cpunks] \n + 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 -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 -- $punkdeck " " $spantable] \n + #append out [textblock::frame -title gr $gr0] + append out [textblock::periodic -forcecolour $opt_forcecolour] + return $out + } + + proc example3 {{text "test\netc\nmore text"}} { + package require patternpunk + .= textblock::join -- [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join -- " " |> .=>1 textblock::join -- $text |> .=>1 textblock::join -- [>punk . rhs] |> .=>1 textblock::join -- [punk::lib::list_as_lines -- [lrepeat 7 " | "]] + } + proc example2 {{text "test\netc\nmore text"}} { + package require patternpunk + .= textblock::join\ + --\ + [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7 8]]\ + [>punk . lhs]\ + " "\ + $text\ + [>punk . rhs]\ + [punk::lib::list_as_lines -- [lrepeat 8 " | "]] + } + proc table {args} { + #todo - use punk::args + upvar ::textblock::class::opts_table_defaults toptdefaults + set defaults [tcl::dict::create\ + -rows [list]\ + -headers [list]\ + -return string\ + ] + + + set defaults [tcl::dict::merge $defaults $toptdefaults] ;# -title -frametype -show_header etc + set opts [tcl::dict::merge $defaults $args] + # -- --- --- --- + set opt_return [tcl::dict::get $opts -return] + set opt_rows [tcl::dict::get $opts -rows] + set opt_headers [tcl::dict::get $opts -headers] + # -- --- --- --- + set topts [tcl::dict::create] + set toptkeys [tcl::dict::keys $toptdefaults] + tcl::dict::for {k v} $opts { + if {$k in $toptkeys} { + tcl::dict::set topts $k $v + } + } + set t [textblock::class::table new {*}$topts] + + foreach h $opt_headers { + $t add_column -headers [list $h] + } + if {[$t column_count] == 0} { + if {[llength $opt_rows]} { + set r0 [lindex $opt_rows 0] + foreach c $r0 { + $t add_column + } + } + } + foreach r $opt_rows { + $t add_row $r + } + + + + if {$opt_return eq "string"} { + set result [$t print] + $t destroy + return $result + } else { + return $t + } + } + + proc frametype {f} { + #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] + switch -- $f { + 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 { + set is_custom_dict_ok 1 + if {[llength $f] %2 == 0} { + #custom dict may leave out keys - but cannot have unknown keys + foreach {k v} $f { + switch -- $k { + all - 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 + break + } + } + } + } else { + set is_custom_dict_ok 0 + } + if {!$is_custom_dict_ok} { + error "frame option -type must be one of known types: $::textblock::frametypes or a dictionary with any of keys all,hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + } + if {[dict exists $f all]} { + return [tcl::dict::create category custom type $f] + } else { + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + set custom_frame [tcl::dict::merge $default_custom $f] + return [tcl::dict::create category custom type $custom_frame] + } + } + } + } + variable framedef_cache [tcl::dict::create] + proc framedef {args} { + #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. + #e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy. + #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. + #the arc set can't even join to itself e.g with curved equivalents of T-like shapes + + #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. + variable framedef_cache + set cache_key $args + if {[tcl::dict::exists $framedef_cache $cache_key]} { + return [tcl::dict::get $framedef_cache $cache_key] + } + + + #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. + #It also means we can't specify checks on the option types etc + set opts [tcl::dict::create\ + -joins ""\ + -boxonly 0\ + ] + set bad_option 0 + 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 $a2 [lindex $args [incr i]] + } + -- { + set values [lrange $args $i+1 end] + break + } + default { + if {[string match -* $a]} { + set bad_option 1 + } else { + set values [lrange $args $i end] + } + break + } + } + } + set f [lindex $values 0] + set rawglobs [lrange $values 1 end] + if {![llength $rawglobs] || "all" in $rawglobs || "*" in $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] { + @id -id ::textblock::framedef + @cmd -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 -optional 1 -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 + } + + set joins [tcl::dict::get $opts -joins] + set boxonly [tcl::dict::get $opts -boxonly] + + + #sorted order down left right up + #1 x choose 4 + #4 x choose 3 + #6 x choose 2 + #4 x choose 1 + #15 combos + + set join_directions [list] + #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode + #e.g down-light, up-heavy + set join_targets [tcl::dict::create left "" down "" right "" up ""] + foreach jt $joins { + lassign [split $jt -] direction target + if {$target ne ""} { + tcl::dict::set join_targets $direction $target + } + lappend join_directions $direction + } + set join_directions [lsort -unique $join_directions] + set do_joins [::join $join_directions _] + + + switch -- $f { + "altg" { + #old style ansi escape sequences with alternate graphics page G0 + set hl [cd::hl] + set hlt $hl + set hlb $hl + set vl [cd::vl] + set vll $vl + set vlr $vl + set tlc [cd::tlc] + set trc [cd::trc] + set blc [cd::blc] + set brc [cd::brc] + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + #No join targets available to join altg to other box styles + switch -- $do_joins { + down { + #1 + set blc [punk::ansi::g0 t] ;#(ltj) + set brc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } left { + #2 + set tlc [punk::ansi::g0 w] ;#(ttj) + set blc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + right { + #3 + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 v] ;#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + up { + #4 + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + } + down_left { + #5 + set blc [punk::ansi::g0 n] ;#(fwj) + set tlc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + down_right { + #6 + set blc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 n] ;#(fwj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_up { + #7 + set blc [punk::ansi::g0 t] ;#(ltj) + set brc [punk::ansi::g0 u] ;#(rtj) + + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set hltj [punk::ansi::g0 v];#(btj) + } + left_right { + #8 + #from 2 + set tlc [punk::ansi::g0 w] ;#(ttj) + set blc [punk::ansi::g0 v] ;#(btj) + #from3 + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + left_up { + #9 + set tlc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 u] ;#(rtj) + set blc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + right_up { + #10 + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 v] ;#(btj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_left_right { + #11 + set blc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 w] ;#(ttj) + set tlc [punk::ansi::g0 w] ;#(ttj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + down_left_up { + #12 + set tlc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 u] ;#(rtj) + set brc [punk::ansi::g0 u] ;#(rtj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + down_right_up { + #13 + set tlc [punk::ansi::g0 t] ;#(ltj) + set blc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + left_right_up { + #14 + set tlc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 v] ;#(btj) + set brc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_left_right_up { + #15 + set tlc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + } + + + } + "ascii" { + 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 $hlt + #set hlbj $hlb + #set vllj $vll + #set vlrj $vlr + #ascii + is small - can reasonably be considered a join to anything? + set hltj + + set hlbj + + set vllj + + set vlrj + + #our corners are all + already - so we won't do anything for directions or targets + + } + "light" { + #unicode box drawing set + set hl [punk::char::charshort boxd_lhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_lv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ldr] + set trc [punk::char::charshort boxd_ldl] + set blc [punk::char::charshort boxd_lur] + set brc [punk::char::charshort boxd_lul] + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #15 combos + #sort order: down left right up + #ltj,rtj,ttj,btj e.g left T junction etc. + #Look at from the perspective of a frame/table outline with a clean border and arms pointing inwards + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'light' + foreach dir {down left right up} { + 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 + } + ascii - altg - arc { + set target$dir light + } + heavy { + set target$dir $target + } + default { + set target$dir other + } + } + } + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + heavy { + set blc [punk::char::charshort boxd_dhrul] ;#\u251f down hieavy and right up light (ltj) + set brc \u2527 ;#boxd_dhlul down heavy and left up light (rtj) + set hlbj \u2530 ;# down heavy (ttj) + } + light { + set blc \u251c ;#[punk::char::charshort boxd_lvr] light vertical and right (ltj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set hlbj \u252c ;# (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + heavy { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + } + light { + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set vllj \u2524 ;# (rtj) + } + } + } + right { + #3 + switch -- $targetright { + heavy { + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + set vlrj \u251d;#right heavy (ltj) + } + light { + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set vlrj \u251c;# (ltj) + } + } + } + up { + #4 + switch -- $targetup { + heavy { + set tlc \u251e ;#up heavy (ltj) + set trc \u2526 ;#up heavy (rtj) + } + light { + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + other-light { + set blc \u2534 ;#(btj) + set tlc \u252c ;#(ttj) + #brc - default corner + set vllj \u2524 ;# (rtj) + } + other-other { + #default corners + } + other-heavy { + set blc \u2535 ;# heavy left (btj) + set tlc \u252d ;#heavy left (ttj) + #brc default corner + set vllj \u2525 ;# heavy left (rtj) + } + heavy-light { + set blc \u2541 ;# heavy down (fwj) + set tlc \u252c ;# light (ttj) + set brc \u2527 ;# heavy down (rtj) + set vllj \u2524 ;# (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + heavy-other { + set blc \u251f ;#heavy down (ltj) + #tlc - default corner + set brc \u2527 ;#heavy down (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + heavy-heavy { + set blc \u2545 ;#heavy down and left (fwj) + set tlc \u252d ;#heavy left (ttj) + set brc \u2527 ;#heavy down (rtj) + set vllj \u2525 ;# heavy left (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + light-light { + set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set tlc \u252c ;# boxd_ldhz (ttj) + set brc \u2524 ;# boxd_lvl light vertical and left(rtj) + set vllj \u2524 ;# (rtj) + set hlbj \u252c ;# (ttj) + } + light-other { + set blc \u251c ;# (ltj) + #tlc - default corner + set brc \u2524 ;# boxd_lvl (rtj) + set hlbj \u252c ;# (ttj) + } + light-heavy { + set blc \u253d ;# heavy left (fwj) + set tlc \u252d ;# heavy left (ttj) + set brc \u2524 ;# light (rtj) + set vllj \u2525 ;# heavy left (rtj) + set hlbj \u252c ;# (ttj) + } + default { + set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set tlc \u252c ;# [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc \u2524 ;# [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + } + } + down_right { + #6 + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + down_up { + #7 + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + left_right { + #8 + #from 2 + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + #from3 + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + + + switch -- $targetleft-$targetright { + heavy-light { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + set vlrj \u251c;#right light (ltj) + } + heavy-other { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + } + heavy-heavy { + set vllj \u2525 ;# left heavy (rtj) + set vlrj \u251d;#right heavy (ltj) + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + } + light-heavy { + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + set vlrj \u251d;#right heavy (ltj) + set vllj \u2524 ;# left light (rtj) + } + light-other { + set vllj \u2524 ;# left light (rtj) + } + light-light { + set vllj \u2524 ;# left light (rtj) + set vlrj \u251c;#right light (ltj) + } + } + #set vllj \u2525 ;# left heavy (rtj) + #set vllj \u2524 ;# left light (rtj) + #set vlrj \u251d;#right heavy (ltj) + #set vlrj \u251c;#right light (ltj) + } + left_up { + #9 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + } + right_up { + #10 + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + } + down_left_right { + #11 + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + + } + down_left_up { + #12 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + + } + down_right_up { + #13 + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + left_right_up { + #14 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + + } + down_left_right_up { + #15 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + } + #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 + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_hv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_hdr] + set trc [punk::char::charshort boxd_hdl] + set blc [punk::char::charshort boxd_hur] + set brc [punk::char::charshort boxd_hul] + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'heavy' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - heavy { + set target$dir heavy + } + light - ascii - altg - arc { + set target$dir light + } + default { + set target$dir other + } + } + } + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + light { + set blc [punk::char::charshort boxd_dlruh] ;#\u2521 down light and right up heavy (ltj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) + set hlbj \u252F ;#down light (ttj) + } + heavy { + set blc [punk::char::charshort boxd_hvr] ;# (ltj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set hlbj \u2533 ;# down heavy (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + light { + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) + set vllj \u2528 ;# left light (rtj) + } + heavy { + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + set vllj \u252b ;#(rtj) + } + } + } + right { + #3 + switch -- $targetright { + light { + set trc [punk::char::charshort boxd_rlldh] ;#\u2531 Right Light and Left Down Heavy (ttj) + set brc [punk::char::charshort boxd_rlluh] ;#\u2539 Right Light and Left Up Heavy(btj) + set vlrj \u2520 ;#right light (ltj) + } + heavy { + set trc [punk::char::charshort boxd_hdhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_huhz] ;# (btj) + set vlrj \u2523 ;# (ltj) + } + } + } + up { + #4 + switch -- $targetup { + light { + set tlc [punk::char::charshort boxd_ulrdh] ;#\u2522 Up Light and Right Down Heavy (ltj) + set trc [punk::char::charshort boxd_ulldh] ;#\u252a Up Light and Left Down Heavy (rtj) + set hltj \u2537 ;# up light (btj) + } + heavy { + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + set hltj \u253b ;# (btj) + } + } + } + down_left { + #down_left is the main join type used for 'L' shaped cell border table building where we boxlimit to {vll hlb blc} + #5 + switch -- down-$targetdown-left-$targetleft { + down-light-left-heavy { + set blc [punk::char::charshort boxd_dluhzh] ;#down light and up horizontal heavy (fwj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) (at tlc down stays heavy) + set hlbj \u252F ;# down light (ttj) + set vllj \u252b ;#(rtj) + } + down-heavy-left-light { + set blc [punk::char::charshort boxd_llrvh] ;# left light and right Vertical Heavy (fwj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) (at brc left must stay heavy) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set hlbj \u2533 ;# down heavy (ttj) + set vllj \u2528 ;# left light (rtj) + } + down-light-left-light { + set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) + set hlbj \u252F ;# down light (ttj) + set vllj \u2528 ;# left light (rtj) + } + down-heavy-left-heavy { + set blc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set hlbj \u2533 ;#(ttj) + set vllj \u252b ;#(rtj) + } + down-other-left-heavy { + set blc \u253b ;#boxd_huhz Heavy Up and Horizontal (btj) + #leave brc default corner + set tlc \u2533 ;#hdhz Heavy Down and Horizontal (ttj) + + set vllj \u252b ;#(rtj) + } + down-other-left-light { + set blc \u253a ;#llruh Left Light and Right Up Heavy (btj) + #leave brc default corner + set tlc \u2532 ;#llrdh Left Light and Right Down Heavy (ttj) + + set vllj \u2528 ;# left light (rtj) + } + down-heavy-left-other { + set blc \u2523 ;#hvr Heavy Vertical and Right (ltj) + set brc \u252b ;#hvl Heavy Veritcal and Left (rtj) + #leave tlc default corner + + set hlbj \u2533 ;#(ttj) + } + down-light-left-other { + set blc \u2521 ;#dlruh Down Light and Right Up Heavy (ltj) + set brc \u2529 ;#dlluh Down Light and Left Up Heavy (rtj) + #leave tlc default corner + + set hlbj \u252F ;# down light (ttj) + } + } + } + down_right { + #6 + set blc [punk::char::charshort boxd_hvr] ;# (ltj) (blc right&up stay heavy) + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) (tlc down&left stay heavy) + set brc [punk::char::charshort boxd_hvhz] ;# (fwj) (brc left&up heavy) + } + down_up { + #7 + set blc [punk::char::charshort boxd_hvr] ;# (ltj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + } + left_right { + #8 + #from 2 + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + #from3 + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) + set brc [punk::char::charshort boxd_huhz] ;# (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) + } + 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) + } + 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) + + } + 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) + + } + 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) + } + 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) + + } + 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) + } + } + } + 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 + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551 + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554 + set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557 + set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A + set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + # \u256c (fwj) + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'double' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - double { + set target$dir double + } + light { + set target$dir light + } + default { + set target$dir other + } + } + } + + #unicode provides no joining for double to anything else + #better to leave a gap by using default double corners if join target is not empty or double + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + double { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + set hlbj \u2566 ;# (ttj) + } + light { + set hlbj \u2564 ;# down light (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + double { + set tlc \u2566 ;# (ttj) + set blc \u2569 ;# (btj) + set vllj \u2563 ;# (rtj) + } + light { + set vllj \u2562 ;# light left (rtj) + } + } + } + right { + #3 + switch -- $targetright { + double { + set trc \u2566 ;# (ttj) + set brc \u2569 ;# (btj) + } + light { + set vlrj \u255F ;# light right (ltj) + } + } + } + up { + #4 + switch -- $targetup { + double { + set tlc \u2560 ;# (ltj) + set trc \u2563 ;# (rtj) + set hltj \u2569 ;# (btj) + } + light { + set hltj \u2567 ;#up light (btj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + double-double { + set blc \u256c ;# (fwj) + set brc \u2563 ;# (rtj) + set tlc \u2566 ;# (ttj) + set hlbj \u2566 ;# (ttj) + } + double-light { + #no corner joins treat corners like 'other' + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + + set hlbj \u2566 ;# (ttj) + set vllj \u2562 ;# light left (rtj) + + } + double-other { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + #leave tlc as ordinary double corner + } + light-double { + + set vllj \u2563 ;# (rtj) + set hlbj \u2564 ;# light down (ttj) + + } + light-light { + + set vllj \u2562 ;# light left (rtj) + set hlbj \u2564 ;# light down (ttj) + } + other-light { + set vllj \u2562 ;# light left (rtj) + } + other-double { + set blc \u2569 ;# (btj) + #leave brc as ordinary double corner + set tlc \u2566 ;# (ttj) + } + } + } + down_right { + #6 + switch -- $targetdown-$targetright { + double-double { + set blc \u2560 ;# (ltj) + set trc \u2566 ;# (ttj) + set brc \u256c ;# (fwj) + set hlbj \u2566 ;# (ttj) + } + double-other { + set blc \u2560 ;# (ltj) + #leave trc default + set brc \u2563 ;# (rtj) + } + other-double { + #leave blc default + set trc \u2566 ;# (ttj) + set brc \u2569 ;#(btj) + } + } + } + down_up { + #7 + switch -- $targetdown-$targetup { + double-double { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + set tlc \u2560 ;# (ltj) + set trc \u2563 ;# (rtj) + set hltj \u2569 ;# (btj) + set hlbj \u2566 ;# (ttj) + } + } + } + left_right { + #8 + + #from 2 + #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_ddhz] ;# (ttj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) + } + left_up { + #9 + 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_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_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_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_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_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_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) + } + } + + } + "arc" { + #unicode box drawing set + + + set hl [punk::char::charshort boxd_lhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_lv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D + set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E + set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 + set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'arc' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - arc { + set target$dir self + } + default { + set target$dir other + } + } + } + + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + self { + set blc \u251c ;# *light (ltj) + #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left + #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable + #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal + + #set brc \u2524 ;# *light(rtj) + #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) + } + } + } + left { + #2 + switch -- $targetleft { + self { + set tlc \u252c ;# *light(ttj) - need a low positioned curved y shape - nothing apparent + #set blc \u2144 ;# (btj) - upside down y - positioning too low for arc + set blc \u2534 ;# *light (btj) + } + } + } + right { + #3 + switch -- $targetright { + self { + set trc \u252c ;# *light (ttj) + #set brc \u2144 ;# (btj) + set brc \u2534 ;# *light (btj) + } + } + } + up { + #4 + switch -- $targetup { + self { + set tlc \u251c ;# *light (ltj) + set trc \u2524 ;# *light(rtj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + self-self { + #set blc \u27e1 ;# white concave-sided diamond - positioned too far right + #set blc \u27e3 ;# concave sided diamond with rightwards tick - positioned too low, too right - big gaps + #set blc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right + set brc \u2524 ;# *light (rtj) + set tlc \u252c ;# *light (ttj) + } + self-other { + #set blc \u2560 ;# (ltj) + #set brc \u2563 ;# (rtj) + #leave tlc as ordinary double corner + } + other-self { + #set blc \u2569 ;# (btj) + #leave brc as ordinary double corner + #set tlc \u2566 ;# (ttj) + } + } + } + down_right { + switch -- $targetdown-$targetright { + self-self { + #set brc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right + set trc \u252c ;# (ttj) + set blc \u2524 ;# (rtj) + } + } + } + } + } + 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 + set hlb \u2594 ;# upper one eighth block + set vll \u258f ;# left one eighth block + set vlr \u2595 ;# right one eighth block + set tlc \u2581 ;# lower one eighth block + set trc \u2581 ;# lower one eighth block + set blc \u2594 ;# upper one eighth block + set brc \u2594 ;# upper one eight block + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + } + block2 { + #the resultant table will have text appear towards top of each box + #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps + set hlt \u2594 ;# upper one eighth block + set hlb \u2581 ;# lower one eighth block + set vlr \u2595 ;# right one eighth block + set vll \u258f ;# left one eighth block + + #some terminals (on windows as at 2024) miscount width of these single-width blocks internally + #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) + #This was fixed in windows-terminal based systems (2021) but persists in others. + #https://github.com/microsoft/terminal/issues/11694 + set tlc \U1fb7d ;#legacy block + set trc \U1fb7e ;#legacy block + set blc \U1fb7c ;#legacy block + set brc \U1fb7f ;#legacy block + + if {[punk::console::check::has_bug_legacysymbolwidth]} { + #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems + set sp \u00a0 ;#non breaking space (plain space may act transparent in some use cases) + set tlc $sp + set trc $sp + set blc $sp + set brc $sp + } + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + } + block2hack { + #the resultant table will have text appear towards top of each box + #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps + set hlt \u2594 ;# upper one eighth block + set hlb \u2581 ;# lower one eighth block + set vlr \u2595 ;# right one eighth block + set vll \u258f ;# left one eighth block + + #see comments in block2 regarding the problems in some terminals that this *may* hack around to some extent. + #the caller probably only needs block2hack if block2 doesn't work + + #1) + #review - this hack looks sort of promising - but overtype::renderline needs fixing ? + #set tlc \U1fb7d\b ;#legacy block + #set trc \U1fb7e\b ;#legacy block + #set blc \U1fb7c\b ;#legacy block + #set brc \U1fb7f\b ;#legacy block + + #2) - works on cmd.exe and some others + # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones + #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) + #this hack has a reasonable chance of working + #except that the punk overtype library does recognise PMs + #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! + #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. + set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block + set trc \U1fb7e\x1b^\b\x1b\\ ;#legacy block + set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block + set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + } + block { + set hlt \u2580 ;#upper half + set hlb \u2584 ;#lower half + set vll \u258c ;#left half + set vlr \u2590 ;#right half + + set tlc \u259b ;#upper left corner half + set trc \u259c + set blc \u2599 + set brc \u259f + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + } + default { + #set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + if {"all" in [dict keys $f]} { + set A [dict get $f all] + set default_custom [tcl::dict::create hl $A vl $A tlc $A trc $A blc $A brc $A] + } + if {[llength $f] % 2} { + #todo - retrieve usage from punk::args + error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $::textblock::frametypes and does not appear to be a dictionary for a custom frametype" + } + #unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults + dict for {k v} $f { + switch -- $k { + all - hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} + default { + error "textblock::frametype '$f' has unknown element '$k'" + } + } + } + #verified keys - safe to extract as vars + set custom_frame [tcl::dict::merge $default_custom $f] + tcl::dict::with custom_frame {} ;#extract keys as vars + #longer j vars must be after their more specific counterparts in the list being processed by foreach + foreach t {hlt hlb vll vlr hltj hlbj vllj vlrj} { + if {[tcl::dict::exists $custom_frame $t]} { + set $t [tcl::dict::get $custom_frame $t] + } else { + #set more explicit type to it's more general counterpart if it's missing + #e.g hlt -> hl + #e.g hltj -> hlt + set $t [set [string range $t 0 end-1]] + } + } + #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set + #horizontal and vertical bar joins - key/variable ends with 'j' + } + } + if {$boxonly} { + set result [tcl::dict::create\ + tlc $tlc hlt $hlt trc $trc\ + vll $vll vlr $vlr\ + blc $blc hlb $hlb brc $brc\ + ] + } else { + set result [tcl::dict::create\ + tlc $tlc hlt $hlt trc $trc\ + vll $vll vlr $vlr\ + blc $blc hlb $hlb brc $brc\ + hltj $hltj\ + hlbj $hlbj\ + vllj $vllj\ + vlrj $vlrj\ + ] + } + 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] + + punk::args::define { + @id -id ::textblock::frame_cache + @cmd -name textblock::frame_cache -help\ + "Display or clear the frame cache." + -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 + } + proc frame_cache {args} { + set argd [punk::args::get_by_id ::textblock::frame_cache $args] + set action [dict get $argd opts -action] + + if {$action ni [list clear ""]} { + error "frame_cache action '$action' not understood. Valid actions: clear" + } + variable frame_cache + if {[dict get $argd opts -pretty]} { + set out [pdict -chan none frame_cache */*] + } else { + set out "" + if {[catch { + set termwidth [tcl::dict::get [punk::console::get_size] columns] + }]} { + set termwidth 80 + } + + tcl::dict::for {k v} $frame_cache { + lassign $v _f frame _used used + set fwidth [textblock::widthtopline $frame] + #review - are cached frames uniform width lines? + #set fwidth [textblock::width $frame] + set frameinfo "$k used:$used " + set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] + if {$allinone_width >= $termwidth} { + #split across 2 lines + append out "$frameinfo\n" + append out $frame \n + } else { + append out [textblock::join -- $frameinfo $frame]\n + } + append out \n ;# frames used to build tables often have joins - keep a line in between for clarity + } + } + if {$action eq "clear"} { + set frame_cache [tcl::dict::create] + append out \nCLEARED + } + return $out + } + + + variable FRAMETYPES + set FRAMETYPES [textblock::frametypes] + variable EG + set EG [a+ brightblack] + variable RST + set RST [a] + + proc frame_samples {} { + set FRAMETYPELABELS [dict create] + if {[info commands ::textblock::frame] ne ""} { + foreach ft [frametypes] { + dict set FRAMETYPELABELS $ft [textblock::frame -checkargs 0 -type $ft " "] + } + } + set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] + return $FRAMETYPELABELS + } + #proc EG {} "return {[a+ brightblack]}" + #make EG fetch from SGR cache so as to abide by colour off/on + proc EG {} { + a+ brightblack + } + #proc RST {} "return {\x1b\[m}" + proc RST {} { + return "\x1b\[m" + } + + #catch 22 for -choicelabels - need some sort of lazy evaluation + # ${[textblock::frame_samples]} + + #todo punk::args alias for centre center etc? + punk::args::define -dynamic 1 { + @id -id ::textblock::frame + @cmd -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 {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ + -choicelabels { + ${[textblock::frame_samples]} + }\ + -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. + ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::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. + ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${[textblock::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. + ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::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. + ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" + } + + #options before content argument - which is allowed to be absent + #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. + # + #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) + # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? + #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand + #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it + # - but we would need to maintain support for the rendered-string based operations too. + proc frame {args} { + variable frametypes + variable use_hash + + #counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var + set opts [tcl::dict::create\ + -etabs 0\ + -type light\ + -boxlimits [list hl vl tlc blc trc brc]\ + -boxmap {}\ + -joins [list]\ + -title ""\ + -subtitle ""\ + -width ""\ + -height ""\ + -ansiborder ""\ + -ansibase ""\ + -blockalign "centre"\ + -textalign "left"\ + -ellipsis 1\ + -usecache 1\ + -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 has_contents 0 + set optlist $args ;#initial only - content will be removed + #no solo opts for frame + if {[llength $args] %2 == 0} { + if {[lindex $args end-1] eq "--"} { + set contents [lpop optlist end] + set has_contents 1 + lpop optlist end ;#drop the end-of-opts flag + } else { + set optlist $args + set contents "" + } + } else { + set contents [lpop optlist 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} $optlist { + 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 + - -checkargs { + tcl::dict::set opts $k2 $v + } + default { + #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 + #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame + if {[llength $args] != 1 && (!$opts_ok || $check_args)} { + set argd [punk::args::get_by_id ::textblock::frame $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_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 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 opt_textalign [tcl::dict::get $opts -textalign] + + 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 + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + + lassign [textblock::frametype $opt_type] _cat category _type ftype + if {$category eq "custom"} { + set custom_frame $ftype + set frameset "custom" + set framedef $custom_frame + } else { + #category = predefined + set frameset $ftype ;# light,heavy etc + set framedef $ftype + } + + #if check_args? + + + #REVIEW - now done in framedef? + #set join_directions [list] + ##targets - light,heavy (double?) - seem to be some required glyphs missing from unicode + ##e.g down-light, up-heavy + #set join_targets [tcl::dict::create left "" down "" right "" up ""] + #foreach jt $opt_joins { + # lassign [split $jt -] direction target + # if {$target ne ""} { + # tcl::dict::set join_targets $direction $target + # } + # lappend join_directions $direction + #} + #set join_directions [lsort -unique $join_directions] + #set do_joins [::join $join_directions _] + + + + + # -- --- --- --- --- --- + + if {$has_contents} { + if {[tcl::string::last \t $contents] >= 0} { + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + if {$opt_etabs} { + #todo + set contents [textutil::tabify::untabify2 $contents $tw] + } + } + set contents [tcl::string::map {\r\n \n} $contents] + if {$opt_crm_mode} { + if {$opt_height eq ""} { + set h [textblock::height $contents] + } else { + set h [expr {$opt_height -2}] + } + if {$opt_width eq ""} { + set w [textblock::width $contents] + } else { + 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 + } + } else { + set actual_contentwidth 0 + set actual_contentheight 0 + } + + if {$opt_title ne ""} { + set titlewidth [punk::ansi::printing_length $opt_title] + set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}] + } else { + set titlewith 0 + set content_or_title_width $actual_contentwidth + } + #opt_subtitle ?? + + if {$opt_width eq ""} { + set frame_inner_width $content_or_title_width + } else { + set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default + } + + if {$opt_height eq ""} { + set frame_inner_height $actual_contentheight + } else { + set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default + } + if {$frame_inner_height == 0 && $frame_inner_width == 0} { + set has_contents 0 + } + #todo - render it with vertical overflow so we can process ansi moves? + #set linecount [textblock::height $contents] + set linecount $frame_inner_height + + # -- --- --- --- --- --- --- --- --- + variable frame_cache + #review - custom frame affects frame_inner_width - exclude from caching? + #set cache_key [concat $optlist $frame_inner_width $frame_inner_height] + #jmn + #set hashables [concat $optlist $frame_inner_width $frame_inner_height] + set hashables [list {*}$optlist $frame_inner_width $frame_inner_height] + + + switch -- $use_hash { + sha1 { + package require sha1 + set hash [sha1::sha1 [encoding convertto utf-8 $hashables]] + } + md5 { + package require md5 + if {[package vsatisfies [package present md5] 2- ] } { + set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review + } else { + set hash [md5::md5 [encoding convertto utf-8 $hashables]] + } + } + none { + set hash $hashables + } + } + + set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth" + #should be in a unicode private range different to that used in table construction + #e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts + #also supplementary private use blocks + #however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult) + #U+F0000 -> U+FFFD + #U+100000 -> U+10FFFD + #FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy) + #should be something someone is unlikely to use as part of a custom frame character. + #ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better) + #As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string + #terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like. + #e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never" + #review - we could consider wasting a few cycles to check for a conflict and use a different FSUB + set FSUB \uF2DD + + + #this occurs commonly in table building with colspans - review + if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { + set usecache 0 + #set buildcache 0 ;#comment out for debug/analysis so we can see + #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" + set cache_key [a+ Web-red web-white]$cache_key[a] + } + if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { + #colourise cache_key to warn + if {$actual_contentwidth == 0} { + #we can still substitute with right length + set cache_key [a+ Web-steelblue web-black]$cache_key[a] + } else { + #actual_contentwidth is narrower than frame - check template's patternwidth + if {[tcl::dict::exists $frame_cache $cache_key]} { + set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] + } else { + set cache_patternwidth $actual_contentwidth + } + if {$actual_contentwidth < $cache_patternwidth} { + set usecache 0 + set cache_key [a+ Web-orange web-black]$cache_key[a] + } elseif {$actual_contentwidth == $cache_patternwidth} { + #set usecache 1 + } else { + #actual_contentwidth > pattern + set usecache 0 + set cache_key [a+ Web-red web-black]$cache_key[a] + } + } + } + + #JMN debug + #set usecache 0 + + set is_cached 0 + if {$usecache && [tcl::dict::exists $frame_cache $cache_key]} { + set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] + set template [tcl::dict::get $frame_cache $cache_key frame] + set used [tcl::dict::get $frame_cache $cache_key used] + tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record + set is_cached 1 + } + + + # -- --- --- --- --- --- --- --- --- + if {!$is_cached} { + # -- --- --- --- --- + # -- --- --- --- --- + set is_joins_ok 1 + foreach v $opt_joins { + lassign [split $v -] direction target + switch -- $direction { + left - right - up - down {} + default { + set is_joins_ok 0 + break + } + } + switch -- $target { + "" - 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 + } + } + } + if {!$is_joins_ok} { + 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 + 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 + } + } + } + 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,hltj,hlbj,vllj,vlrj" + } + # -- --- --- --- --- --- + #these are all valid commands for overtype:: + switch -- $opt_textalign { + left - right - centre - center {} + default { + error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" + } + } + # -- --- --- --- --- --- + switch -- $opt_blockalign { + left - right - centre - center {} + default { + error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign" + } + } + # -- --- --- --- --- + # -- --- --- --- --- + set is_boxlimits_ok 1 + set exact_boxlimits [list] + foreach v $opt_boxlimits { + switch -- $v { + hl { + lappend exact_boxlimits hlt hlb + } + vl { + lappend exact_boxlimits vll vlr + } + hlt - hlb - vll - vlr - tlc - trc - blc - brc { + lappend exact_boxlimits $v + } + default { + #k not in custom_keys + set is_boxlimits_ok 0 + break + } + } + } + #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" + } + set exact_boxlimits [lsort -unique $exact_boxlimits] + # -- --- --- --- --- --- + + + set rst [a] + #set column [tcl::string::repeat " " $frame_inner_width] ;#default - may need to override for custom frame + set underlayline [tcl::string::repeat " " $frame_inner_width] + set underlay [::join [lrepeat $linecount $underlayline] \n] + + + set vll_width 1 ;#default for all except custom (printing width) + set vlr_width 1 + + set framedef [textblock::framedef -joins $opt_joins $framedef] + tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars + + #puts "---> $opt_boxmap" + #review - we handle double-wide in custom frames - what about for boxmaps? + tcl::dict::for {boxelement sub} $opt_boxmap { + if {$boxelement eq "vl"} { + set vll $sub + set vlr $sub + set hl $sub + } elseif {$boxelement eq "hl"} { + set hlt $sub + set hlb $sub + set hl $sub + } else { + set $boxelement $sub + } + } + + switch -- $frameset { + custom { + #REVIEW - textblock::table assumes that at least the vl elements are 1-wide + #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though + #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely + set vll_width [punk::ansi::printing_length $vll] + set hlb_width [punk::ansi::printing_length $hlb] + set hlt_width [punk::ansi::printing_length $hlt] + + set vlr_width [punk::ansi::printing_length $vlr] + + set tlc_width [punk::ansi::printing_length $tlc] + set trc_width [punk::ansi::printing_length $trc] + set blc_width [punk::ansi::printing_length $blc] + set brc_width [punk::ansi::printing_length $brc] + + + set framewidth [expr {$frame_inner_width + 2}] ;#reverse default assumption + if {$opt_width eq ""} { + #width wasn't specified - so user is expecting frame to adapt to title/contents + #content shouldn't truncate because of extra wide frame + #review - punk::console::get_size ? wrapping? quite hard to support with colspans + set frame_inner_width $content_or_title_width + set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width + set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] + } else { + set frame_inner_width [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated + set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}] + set bbarwidth [expr {$opt_width - $blc_width - $brc_width}] + } + #set column [tcl::string::repeat " " $frame_inner_width] + set underlayline [tcl::string::repeat " " $frame_inner_width] + set underlay [::join [lrepeat $linecount $underlayline] \n] + #cache? + + if {$hlt_width == 1} { + set tbar [tcl::string::repeat $hlt $tbarwidth] + } else { + #possibly mixed width chars that make up hlt - tcl::string::range won't get width right + set blank [tcl::string::repeat " " $tbarwidth] + if {$hlt_width > 0} { + set count [expr {($tbarwidth / $hlt_width) + 1}] + } else { + set count 0 + } + set tbar [tcl::string::repeat $hlt $count] + #set tbar [tcl::string::range $tbar 0 $tbarwidth-1] + set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character + } + if {$hlb_width == 1} { + set bbar [tcl::string::repeat $hlb $bbarwidth] + } else { + set blank [tcl::string::repeat " " $bbarwidth] + if {$hlb_width > 0} { + set count [expr {($bbarwidth / $hlb_width) + 1}] + } else { + set count 0 + } + set bbar [tcl::string::repeat $hlb $count] + #set bbar [tcl::string::range $bbar 0 $bbarwidth-1] + set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] + } + } + altg { + set tbar [tcl::string::repeat $hlt $frame_inner_width] + set tbar [cd::groptim $tbar] + set bbar [tcl::string::repeat $hlb $frame_inner_width] + set bbar [cd::groptim $bbar] + } + default { + set tbar [tcl::string::repeat $hlt $frame_inner_width] + set bbar [tcl::string::repeat $hlb $frame_inner_width] + + } + } + + set leftborder 0 + set rightborder 0 + set topborder 0 + set bottomborder 0 + # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + #puts "----->$exact_boxlimits" + foreach lim $exact_boxlimits { + switch -- $lim { + hlt { + set topborder 1 + } + hlb { + set bottomborder 1 + } + vll { + set leftborder 1 + } + vlr { + set rightborder 1 + } + tlc { + set topborder 1 + set leftborder 1 + } + trc { + set topborder 1 + set rightborder 1 + } + blc { + set bottomborder 1 + set leftborder 1 + } + brc { + set bottomborder 1 + set rightborder 1 + } + } + } + if {$opt_width ne "" && $opt_width < 2} { + set rightborder 0 + } + #keep lhs/rhs separate? can we do vertical text on sidebars? + set lhs [tcl::string::repeat $vll\n $linecount] + set lhs [tcl::string::range $lhs 0 end-1] + set rhs [tcl::string::repeat $vlr\n $linecount] + set rhs [tcl::string::range $rhs 0 end-1] + + + if {$opt_ansiborder ne ""} { + set tbar $opt_ansiborder$tbar$rst + set bbar $opt_ansiborder$bbar$rst + set tlc $opt_ansiborder$tlc$rst + set trc $opt_ansiborder$trc$rst + set blc $opt_ansiborder$blc$rst + set brc $opt_ansiborder$brc$rst + + set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out + set rhs $opt_ansiborder$rhs$rst + } + + #boxlimits used for partial borders in table generation + set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] + set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] + foreach lim $unspecified_limits { + switch -- $lim { + vll { + set blank_vll [tcl::string::repeat " " $vll_width] + set lhs [tcl::string::repeat $blank_vll\n $linecount] + set lhs [tcl::string::range $lhs 0 end-1] + } + vlr { + set blank_vlr [tcl::string::repeat " " $vlr_width] + set rhs [tcl::string::repeat $blank_vlr\n $linecount] + set rhs [tcl::string::range $rhs 0 end-1] + } + hlt { + set bar_width [punk::ansi::printing_length $tbar] + set tbar [tcl::string::repeat " " $bar_width] + } + tlc { + set tlc_width [punk::ansi::printing_length $tlc] + set tlc [tcl::string::repeat " " $tlc_width] + } + trc { + set trc_width [punk::ansi::printing_length $trc] + set trc [tcl::string::repeat " " $trc_width] + } + hlb { + set bar_width [punk::ansi::printing_length $bbar] + set bbar [tcl::string::repeat " " $bar_width] + } + blc { + set blc_width [punk::ansi::printing_length $blc] + set blc [tcl::string::repeat " " $blc_width] + } + brc { + set brc_width [punk::ansi::printing_length $brc] + set brc [tcl::string::repeat " " $brc_width] + } + } + } + + if {$opt_title ne ""} { + set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off + } else { + set topbar $tbar + } + if {$opt_subtitle ne ""} { + set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off + } else { + set bottombar $bbar + } + if {$opt_ansibase eq ""} { + set rstbase [a] + } else { + set rstbase [a]$opt_ansibase + } + + if {$opt_title ne ""} { + #title overrides -boxlimits for topborder + set topborder 1 + } + set fs "" + set fscached "" + set cache_patternwidth 0 + #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? + if {$topborder} { + if {$leftborder && $rightborder} { + append fs $tlc$topbar$trc + } else { + if {$leftborder} { + append fs $tlc$topbar + } elseif {$rightborder} { + append fs $topbar$trc + } else { + append fs $topbar + } + } + } + append fscached $fs + if {$has_contents || $opt_height > 2} { + #if {$topborder && $fs ne "xx"} { + # append fs \n + #} + if {$topborder} { + append fs \n + append fscached \n + } + switch -- $opt_textalign { + right {set pad "left"} + left {set pad "right"} + default {set pad $opt_textalign} + } + #set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1] + #set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents] + + set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth] + set cache_patternwidth $actual_contentwidth + set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] + set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] + #after overtype::block - our actual patternwidth may be less + set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] + + if {$leftborder && $rightborder} { + #set bodyparts [list $lhs $inner $rhs] + set cache_bodyparts [list $lhs $cache_inner $rhs] + } else { + if {$leftborder} { + #set bodyparts [list $lhs $inner] + set cache_bodyparts [list $lhs $cache_inner] + } elseif {$rightborder} { + #set bodyparts [list $inner $rhs] + set cache_bodyparts [list $cache_inner $rhs] + } else { + #set bodyparts [list $inner] + set cache_bodyparts [list $cache_inner] + } + } + #set body [textblock::join -- {*}$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 + } + + if {$opt_height eq "" || $opt_height > 1} { + if {$opt_subtitle ne ""} { + #subtitle overrides boxlimits for bottomborder + set bottomborder 1 + } + if {$bottomborder} { + if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { + #append fs \n + append fscached \n + } + if {$leftborder && $rightborder} { + #append fs $blc$bottombar$brc + append fscached $blc$bottombar$brc + } else { + if {$leftborder} { + #append fs $blc$bottombar + append fscached $blc$bottombar + } elseif {$rightborder} { + #append fs $bottombar$brc + append fscached $bottombar$brc + } else { + #append fs $bottombar + append fscached $bottombar + } + } + } + } + set template $fscached + ;#end !$is_cached + } + + + + + #use the same mechanism to build the final frame - whether from cache or template + if {$actual_contentwidth == 0} { + set fs [tcl::string::map [list $FSUB " "] $template] + } else { + set resultlines [list] + set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] + set contentindex 0 + switch -- $opt_textalign { + left {set pad right} + right {set pad left} + default {set pad $opt_textalign} + } + + #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] ""] ;# should not affect actual_contentwidth + } + + #set cwidth [textblock::width $contents] + set cwidth $actual_contentwidth + if {$opt_pad} { + 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} { + set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] + } + #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 { + if {$cwidth > $cache_patternwidth} { + set contents [overtype::renderspace -width $cache_patternwidth "" $contents] + } + set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line + } + + set tlines [split $template \n] + + #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. + #after textblock::join the reset will be a separate code ie should be exactly ESC[0m + set R [a] + set rlen [tcl::string::length $R] + set clines [split $contentblock \n] + + foreach tline $tlines { + if {[tcl::string::first $FSUB $tline] >= 0} { + set content_line [lindex $clines $contentindex] + if {[tcl::string::first $R [string range $content_line 0 10]] == 0} { + set content_line [tcl::string::range $content_line $rlen end] + } + #make sure to replay opt_ansibase to the right of the replacement + lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline] + incr contentindex + } else { + lappend resultlines $tline + } + } + set fs [::join $resultlines \n] + } + + + if {$is_cached} { + return $fs + } else { + if {$buildcache} { + tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] + } + return $fs + } + } + punk::args::define { + @id -id ::textblock::gcross + -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block + Only cross sizes that divide the size of the overall block will be used. + e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. + Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) + If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. + " + @values -min 0 -max 1 + size -default 1 -type integer + } + proc gcross {args} { + set argd [punk::args::get_by_id ::textblock::gcross $args] + set size [dict get $argd values size] + set opts [dict get $argd opts] + + if {$size == 0} { + return "" + } + + set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] + + #set fit_size [punk::lib::greatestOddFactor $size] + set fit_size $size + if {$opt_max_cross_size == 0} { + set max_cross_size $fit_size + } else { + #todo - only allow divisors + #set testsize [expr {min($fit_size,$opt_max_cross_size)}] + + set factors [punk::lib::factors $size] + #pick odd size in list that is smaller or equal to test_size + set max_cross_size [lindex $factors end] + set last_ok [lindex $factors 0] + for {set i 0} {$i < [llength $factors]} {incr i} { + set s [lindex $factors $i] + if {$s > $opt_max_cross_size} { + break + } + set last_ok $s + } + set max_cross_size $last_ok + } + set crosscount [expr {$size / $max_cross_size}] + + package require punk::char + set x [punk::char::charshort boxd_ldc] + set bs [punk::char::charshort boxd_ldgullr] + set fs [punk::char::charshort boxd_ldgurll] + + set onecross "" + set crossrows [list] + set armsize [expr {int(floor($max_cross_size /2))}] + set row [lrepeat $max_cross_size " "] + #toparm + for {set i 0} {$i < $armsize} {incr i} { + set r $row + lset r $i $bs + lset r end-$i $fs + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + + if {$max_cross_size % 2} { + #only put centre cross in for odd sized crosses + set r $row + lset r $armsize $x + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + + for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} { + set r $row + lset r $i $fs + lset r end-$i $bs + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + #set onecross [tcl::string::trimright $onecross \n] + set onecross [::join $crossrows \n] + + #fastest to do row first then columns - because textblock::join must do line by line + + if {$crosscount > 1} { + set row [textblock::join -- {*}[lrepeat $crosscount $onecross]] + set rows [lrepeat $crosscount $row] + set out [::join $rows \n] + } else { + set out $onecross + } + + return $out + } + + #Test we can join two coloured blocks + proc test_colour {} { + set b1 [a red]1\n2\n3[a] + set b2 [a green]a\nb\nc[a] + set result [textblock::join -- $b1 $b2] + puts $result + #return [list $b1 $b2 $result] + return [ansistring VIEW $result] + } + tcl::namespace::import ::punk::ansi::ansistrip +} + + +tcl::namespace::eval ::textblock::piper { + tcl::namespace::export * + proc join {rhs pipelinedata} { + tailcall ::textblock::join -- $pipelinedata $rhs + } +} +interp alias {} piper_blockjoin {} ::textblock::piper::join + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide textblock [tcl::namespace::eval textblock { + variable version + set version 0.1.3 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm index d7d9813e..ee486569 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm @@ -211,6 +211,7 @@ namespace eval commandstack { set new_code [string trim $procbody] if {$current_code eq $new_code} { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [show_stack $command] } else { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." puts stdout "----------" @@ -223,6 +224,7 @@ namespace eval commandstack { } } else { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" + puts stderr set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid set do_rename 1 } @@ -374,13 +376,13 @@ namespace eval commandstack { proc show_stack {{commandname_glob *}} { variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } if {[package provide punk::lib] ne ""} { return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] } else { - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } set result "" set matchedkeys [dict keys $all_stacks $commandname_glob] #don't try to calculate widest on empty list diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm index 0d9cd0bc..fb044b3c 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm @@ -449,7 +449,7 @@ tcl::namespace::eval overtype { 4 { set inputchunks [list] foreach ln [split $overblock \n] { - lappend inputchunks [string cat $ln \n] + lappend inputchunks $ln\n } if {[llength $inputchunks]} { lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] @@ -499,9 +499,9 @@ tcl::namespace::eval overtype { #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set overtext $replay_codes_overlay$overtext if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::string::cat [tcl::dict::get $replay_codes_underlay $row] $undertext] + set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l @@ -1365,8 +1365,8 @@ tcl::namespace::eval overtype { set udiff [expr {$renderwidth - $ulen}] set undertext "$undertext[string repeat { } $udiff]" } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] #review - right-to-left langs should elide on left! - extra option required @@ -1518,8 +1518,8 @@ tcl::namespace::eval overtype { set startoffset 0 ;#negative? } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] if {$overflowlength > 0} { @@ -1545,7 +1545,7 @@ tcl::namespace::eval overtype { } } if {$show_ellipsis} { - set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] + set ellipsis $replay_codes$opt_ellipsistext #todo - overflow on left if allign = right?? set rendered [overtype::right $rendered $ellipsis] } @@ -1701,8 +1701,8 @@ tcl::namespace::eval overtype { set startoffset 0 ;#negative? } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] if {$overflowlength > 0} { @@ -1769,6 +1769,9 @@ tcl::namespace::eval overtype { return [join $outputlines \n] } + + variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. @@ -1802,6 +1805,7 @@ tcl::namespace::eval overtype { #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. #puts stderr "renderline '$args'" + variable optimise_ptruns if {[llength $args] < 2} { error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} @@ -1973,58 +1977,107 @@ tcl::namespace::eval overtype { foreach {pt code} $undermap { #pt = plain text #append pt_underchars $pt - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. - #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. - #todo - test decimal value instead, compare performance - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - set width 1 + if {$pt ne ""} { + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex + set re [tcl::string::cat {^[} \\U$hex {]+$}] + set is_ptrun [regexp $re $pt] + } + if {$is_ptrun} { + #switch -- $p1 { + # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + # set width 1 + # } + # default { + # if {$p1 eq "\u0000"} { + # #use null as empty cell representation - review + # #use of this will probably collide with some application at some point + # #consider an option to set the empty cell character + # set width 1 + # } else { + # set width [grapheme_width_cached $p1] ;# when zero??? + # } + # } + #} + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] + lappend undercols {*}[lrepeat $ptlen $p1] + } else { + incr i_u $ptlen ;#2nd col empty str - so same as above + set 2ptlen [expr {$ptlen * 2}] + lappend understacks {*}[lrepeat $2ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]] + lappend undercols {*}$l + unset l } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] - set grapheme $gvis + + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + set width 1 + } + default { + if {$grapheme eq "\u0000"} { + #use null as empty cell representation - review + #use of this will probably collide with some application at some point + #consider an option to set the empty cell character set width 1 + } else { + #zero width still acts as 1 below??? review what should happen + set width [grapheme_width_cached $grapheme] + #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length + #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI + #todo - default to off and add a flag (?) to enable this substitution + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. + set grapheme $gvis + set width 1 + } + } } } } + + #set width [grapheme_width_cached $grapheme] + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + + lappend undercols $grapheme + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + #but what about emoji combinations etc - can they be wider than 2? + #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + lappend undercols "" + } } - } - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" + } } - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2168,23 +2221,31 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left of the right number of columns. + #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpad_overlay [string repeat " " [expr {$opt_colstart -1}]] - append startpad_overlay $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - if {$startpad_overlay ne ""} { - if {[punk::ansi::ta::detect $startpad_overlay]} { - set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] + set startpadding [string repeat " " [expr {$opt_colstart -1}]] + #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + if {$startpadding ne "" || $overdata ne ""} { + if {[punk::ansi::ta::detect $overdata]} { + set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] } else { #single plaintext part - set overmap [list $startpad_overlay] + set overmap [list $startpadding$overdata] } } else { set overmap [list] } - #set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] #### + + #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) + #will that allow some optimisations? + + #todo - detect repeated transparent char in overlay + #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. + # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data + #we should be able to optimize to pass through the underlay?? + #??? set colcursor $opt_colstart #TODO - make a little virtual column object @@ -2206,41 +2267,78 @@ tcl::namespace::eval overtype { #experiment set overlay_grapheme_control_stacks [list] foreach {pt code} $overmap { - - #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - if {!$crm_mode} { - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack + if {$pt ne ""} { + #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] } - } else { - set tsbegin [clock micros] - foreach grapheme_original [punk::char::grapheme_split $pt] { - set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] - #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" - foreach grapheme [punk::char::grapheme_split $pt_crm] { - if {$grapheme eq "\n"} { + append pt_overchars $pt + #will get empty pt between adjacent codes + if {!$crm_mode} { + + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] + set is_ptrun [regexp $re $pt] + + #leading only? we would have to check for graphemes at the trailing boundary? + #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] + #set is_ptrun [regexp -indices $re $pt runrange] + #if {$is_ptrun && 1} { + #} + } + if {$is_ptrun} { + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) + set len [string length $pt] + set g_element [list g $p1] + + #lappend overstacks {*}[lrepeat $len $o_codestack] + #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] + #incr i_o $len + #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] + #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] + + set pi 0 + incr i_o $len + while {$pi < $len} { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + lappend overlay_grapheme_control_list $g_element lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] - } else { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack + incr pi + } + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_list [list g $grapheme] lappend overlay_grapheme_control_stacks $o_codestack } } + } else { + set tsbegin [clock micros] + foreach grapheme_original [punk::char::grapheme_split $pt] { + set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" + foreach grapheme [punk::char::grapheme_split $pt_crm] { + if {$grapheme eq "\n"} { + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] + } else { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } - set elapsed [expr {[clock micros] - $tsbegin}] - puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2324,6 +2422,7 @@ tcl::namespace::eval overtype { set o_codestack [list $temp_cursor_saved] lappend overlay_grapheme_control_list [list other $code] } else { + #review if {[punk::ansi::codetype::is_gx_open $code]} { set o_gxstack [list "gx0_on"] lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets @@ -2837,7 +2936,8 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] } 7CSI - 7OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + set codenorm $leadernorm[tcl::string::range $code 2 end] } 7DCS { #ESC P @@ -2849,7 +2949,8 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] } 7ESC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + set codenorm $leadernorm[tcl::string::range $code 1 end] } 8CSI - 8OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] @@ -2886,7 +2987,12 @@ tcl::namespace::eval overtype { A { #Row move - up set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set num $param + #todo + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} incr cursor_row -$num @@ -2904,9 +3010,12 @@ tcl::namespace::eval overtype { B { #CUD - Cursor Down #Row move - down - set num $param + lassign [split $param {;}] num modifierkey set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #move down + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} incr cursor_row $num @@ -2924,7 +3033,10 @@ tcl::namespace::eval overtype { #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. #cursor forward #right-arrow/move forward - set num $param + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} #todo - retrict to moving 1 position past datalen? restrict to column width? @@ -3028,7 +3140,10 @@ tcl::namespace::eval overtype { #puts stdout "<-back" #cursor back #left-arrow/move-back when ltr mode - set num $param + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} set version 2 @@ -4518,7 +4633,7 @@ tcl::namespace::eval overtype::priv { if {$existing eq "\0"} { lset o $i $c } else { - lset o $i [string cat $existing $c] + lset o $i $existing$c } } #is actually addgrapheme? diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm index 1a9ab766..08359461 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm @@ -12,6 +12,242 @@ namespace eval punk { #lazyload twapi ? catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later + + variable can_exec_windowsapp + set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed + variable windowsappdir + set windowsappdir "" + variable cmdexedir + set cmdexedir "" + + proc rehash {{refresh 0}} { + global auto_execs + if {!$refresh} { + unset -nocomplain auto_execs + } else { + set names [array names auto_execs] + unset -nocomplain auto_execs + foreach nm $names { + auto_execok_windows $nm + } + } + return + } + + + proc ::punk::auto_execok_original name [info body ::auto_execok] + variable better_autoexec + + #set better_autoexec 0 ;#use this var via better_autoexec only + #proc ::punk::auto_execok_windows name { + # ::punk::auto_execok_original $name + #} + + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + + set has_commandstack [expr {![catch {package require commandstack}]}] + if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} { + + #still a caching version of auto_execok - but with proper(fixed) search order + + #set b [info body ::auto_execok] + #proc ::auto_execok_original name $b + + proc better_autoexec {{onoff ""}} { + variable better_autoexec + if {$onoff eq ""} { + return $better_autoexec + } + if {![string is boolean -strict $onoff]} { + error "better_autoexec argument 'onoff' must be a boolean, received: $onoff" + } + if {$onoff && ($onoff != $better_autoexec)} { + puts "Turning on better_autoexec - search PATH first then extension" + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + punk::rehash + } elseif {!$onoff && ($onoff != $better_autoexec)} { + puts "Turning off better_autoexec - search extension then PATH" + set better_autoexec 0 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_original $name + } + punk::rehash + } else { + puts "no change" + } + } + #better_autoexec $better_autoexec ;#init to default + + + proc auto_execok_better name { + global auto_execs env tcl_platform + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + #puts stdout "[a+ red]...[a]" + set auto_execs($name) "" + + set shellBuiltins [list assoc cls copy date del dir echo erase exit ftype \ + md mkdir mklink move rd ren rename rmdir start time type ver vol] + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + if {[string tolower $name] in $shellBuiltins} { + # When this is command.com for some reason on Win2K, Tcl won't + # exec it unless the case is right, which this corrects. COMSPEC + # may not point to a real file, so do the check. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext $execExtensions { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + return "" + } + + #change1 + #set path "[file dirname [info nameofexecutable]];.;" + set path "[file dirname [info nameofexecutable]];" + + if {[info exists env(SystemRoot)]} { + set windir $env(SystemRoot) + } elseif {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + append path "$windir/system32;$windir/system;$windir;" + } + + foreach var {PATH Path path} { + if {[info exists env($var)]} { + append path ";$env($var)" + } + } + + #change2 + set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + foreach dir [split $path {;}] { + #set dir [file normalize $dir] + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} + + foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] { + set file [file join $dir $match] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + } + + #foreach ext $execExtensions { + #unset -nocomplain checked + #foreach dir [split $path {;}] { + # # Skip already checked directories + # if {[info exists checked($dir)] || ($dir eq "")} { + # continue + # } + # set checked($dir) {} + # set file [file join $dir ${name}${ext}] + # if {[file exists $file] && ![file isdirectory $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + #} + return "" + } + + + + #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? + #what if we create another interp and use the same ::auto_execs? The appdir won't be detected. + #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed + + + + #winget is installed on all modern windows and is an example of the problem this addresses + #we target apps with same location + + #the main purpose of this override is to support windows app executables (installed as 'reparse points') + #for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac + #versions prior to this will use cmd.exe to resolve the links + set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name { + #set windowsappdir "%appdir%" + upvar ::punk::can_exec_windowsapp can_exec_windowsapp + upvar ::punk::windowsappdir windowsappdir + upvar ::punk::cmdexedir cmdexedir + + if {$windowsappdir eq ""} { + #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' + #Tcl (2025) can't exec when given a path to these 0KB files + #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps + if {!([info exists ::env(LOCALAPPDATA)] && + [file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} { + #should be unlikely to get here - unless LOCALAPPDATA missing + set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]] + puts stderr "(resolved winget by search)" + } else { + set windowsappdir [file dirname $testapp] + } + } + + #set default_auto [$COMMANDSTACKNEXT $name] + set default_auto [::punk::auto_execok_windows $name] + #if {$name ni {cmd cmd.exe}} { + # unset -nocomplain ::auto_execs + #} + + if {$default_auto eq ""} { + return + } + set namedir [file dirname [lindex $default_auto 0]] + + if {$namedir eq $windowsappdir} { + if {$can_exec_windowsapp eq "unknown"} { + if {[catch {exec [file join $windowsappdir winget.exe] --version}]} { + set can_exec_windowsapp 0 + } else { + set can_exec_windowsapp 1 + } + } + if {$can_exec_windowsapp} { + return [file join $windowsappdir $name] + } + if {$cmdexedir eq ""} { + #cmd.exe very unlikely to move + set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] + #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index + #anyway.. it has other side effects (affects auto_load) + } + return "[file join $cmdexedir cmd.exe] /c $name" + } + return $default_auto + }] + + + } + } @@ -5321,8 +5557,8 @@ namespace eval punk { } return -options $opts $msg } else { - dict incr opts -level - return -options $opts $msg + dict incr opts -level + return -options $opts $msg } } } @@ -7152,7 +7388,7 @@ namespace eval punk { dict filter $result value {?*} } - punk::args::definition { + punk::args::define { @id -id ::punk::inspect @cmd -name punk::inspect -help\ "Function to display values - used pimarily in a punk pipeline. diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index c17bacf2..296bb6df 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -115,6 +115,7 @@ tcl::namespace::eval punk::aliascore { pdict ::punk::lib::pdict\ plist {::punk::lib::pdict -roottype list}\ showlist {::punk::lib::showdict -roottype list}\ + rehash ::punk::rehash\ showdict ::punk::lib::showdict\ ansistrip ::punk::ansi::ansistrip\ stripansi ::punk::ansi::ansistrip\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index a3f9c0b5..422c524e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -5568,6 +5568,7 @@ tcl::namespace::eval punk::ansi::class { } #does not affect object state + #REVIEW - icu or equiv required method DoCount {plaintext} { #- combiners/diacritics just map them away here - but for consistency we need to combine unicode grapheme clusters too. #todo - joiners 200d? zwnbsp @@ -5672,6 +5673,7 @@ tcl::namespace::eval punk::ansi::class { method renderbuf {} { #get the underlying renderobj - if any #return $o_renderout ;#also class_ansistring + if {$o_renderer eq ""} {error "renderbuf error: no active renderer"} return [$o_renderer renderbuf] } method render {{maxgraphemes ""}} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm index 2c9c77fa..78a18304 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm @@ -247,12 +247,12 @@ tcl::namespace::eval punk::args::register { tcl::namespace::eval punk::args { - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::definition at the end. + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. tcl::namespace::export {[a-z]*} variable argdata_cache variable argdefcache_by_id - variable argdefcache_unresolved + variable argdefcache_unresolved ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) variable id_counter set argdata_cache [tcl::dict::create] set argdefcache_by_id [tcl::dict::create] @@ -282,10 +282,18 @@ tcl::namespace::eval punk::args { set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::definition + @id -id ::punk::args::define #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::definition -help\ + @cmd -name punk::args::define -help\ "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + This can be used purely for documentation or called within a function to parse a mix of leading values, switches/flags and trailing values. @@ -427,10 +435,13 @@ tcl::namespace::eval punk::args { " @values -min 1 -max -1 text -type string -multiple 1 -help\ - "Block(s) of text representing the argument specification for a command. + "Block(s) of text representing the argument definition for a command. At least one must be supplied. If multiple, they are joined together with \\n. Using multiple text arguments may be useful to mix curly-braced and double-quoted strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + e.g the following definition passes 2 blocks as text arguments definition { @id -id ::myns::myfunc @@ -450,22 +461,135 @@ tcl::namespace::eval punk::args { } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" " }]] - proc definition {args} { + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -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_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + proc define {args} { variable argdata_cache variable argdefcache_by_id variable argdefcache_unresolved - #variable initial_optspec_defaults - #variable initial_valspec_defaults + set cache_key $args #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) #review - check if there is a built-into-tcl way to do this quickly #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. - set cache_key $args set textargs $args - + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } set is_dynamic 0 if {[lindex $args 0] eq "-dynamic"} { set is_dynamic [lindex $args 1] @@ -485,6 +609,8 @@ tcl::namespace::eval punk::args { set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] } } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] lassign $pt_params ptlist paramlist @@ -509,6 +635,7 @@ tcl::namespace::eval punk::args { tcl::dict::set argdefcache_unresolved $cache_key $pt_params } } + #argdata_cache should be limited in some fashion or will be a big memory leak??? if {[tcl::dict::exists $argdata_cache $optionspecs]} { #resolved cache version exists return [tcl::dict::get $argdata_cache $optionspecs] @@ -517,46 +644,6 @@ tcl::namespace::eval punk::args { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -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_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] #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 @@ -566,21 +653,14 @@ tcl::namespace::eval punk::args { #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 leader_required [list] set opt_required [list] set val_required [list] - set arg_info [tcl::dict::create] - set arg_checks [tcl::dict::create] set opt_defaults [tcl::dict::create] - set opt_names [list] ;#defined opts - set leader_defaults [tcl::dict::create] set val_defaults [tcl::dict::create] set opt_solos [list] - #first process dashed and non-dashed argspecs without regard to whether non-dashed are at the beginning or end - set leader_names [list] - set val_names [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end set records [list] set linebuild "" @@ -602,7 +682,7 @@ tcl::namespace::eval punk::args { foreach rawline $linelist { set recordsofar [tcl::string::cat $linebuild $rawline] #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in argspecs. + #review - when exactly are ansi codes allowed/expected in record lines. # - we might reasonably expect them in default values or choices or help strings # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. # - eg set line "set x \"a[a+ red]red[a]\"" @@ -656,48 +736,137 @@ tcl::namespace::eval punk::args { set id_info {} ;#e.g -children ?? set doc_info {} set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set parser_info {} - set leader_min "" - #set leader_min 0 - #set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - set leader_max "" + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" #(common case of no leaders specified) set opt_any 0 set val_min 0 set val_max -1 ;#-1 for no limit - set spec_id "" - set argspace "leaders" ;#leaders -> options -> values - set parser_id 0 - foreach ln $records { - set trimln [tcl::string::trim $ln] - switch -- [tcl::string::index $trimln 0] { + set DEF_definition_id "" + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { "" - # {continue} } - set linespecs [lassign $trimln argname] - if {[llength $linespecs] % 2 != 0} { - error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs' id:$spec_id" + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } } - set firstchar [tcl::string::index $argname 0] - set secondchar [tcl::string::index $argname 1] + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] if {$firstchar eq "@" && $secondchar ne "@"} { - set at_specs $linespecs + set record_type "directive" + set directive_name $firstword + set at_specs $record_values - switch -- [tcl::string::range $argname 1 end] { + switch -- [tcl::string::range $directive_name 1 end] { id { #id An id will be allocated if no id line present or the -id value is "auto" - if {$spec_id ne ""} { + if {$DEF_definition_id ne ""} { #disallow duplicate @id line - error "punk::args::definition - @id already set. Existing value $spec_id" + error "punk::args::define - @id already set. Existing value $DEF_definition_id" } if {[dict exists $at_specs -id]} { - set spec_id [dict get $at_specs -id] + set DEF_definition_id [dict get $at_specs -id] } else { - set spec_id auto + set DEF_definition_id auto } set id_info $at_specs } + ref { + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } default { - #copy from an identified set of defaults (another argspec id) can be multiple + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define -dynamic 1 making *immediate* resolutions .. is that really desirable? + if {[dict exists $at_specs -id]} { set copyfrom [get_def [dict get $at_specs -id]] #we don't copy the @id info from the source @@ -711,20 +880,27 @@ tcl::namespace::eval punk::args { if {![dict size $doc_info]} { set doc_info [dict get $copyfrom doc_info] } - if {![dict size $argdisplay_info]} { - set argdisplay_info [dict get $copyfrom argdisplay_info] + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? } - #TODO - #create leaders opts vals depending on position of @default line? - #options on @default line to exclude/include sets??? } } } - parser { + form { + # arity system ? #handle multiple parsing styles based on arities and keyword positions (and/or flags?) #e.g see lseq manual with 3 different parsing styles. #aim to produce a table/subtable for each - # *parser -description "start ?('..'|'to')? end ??'by'? step?"\ + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ # -arities { # 2 # {3 anykeys {1 .. 1 to}} @@ -733,24 +909,36 @@ tcl::namespace::eval punk::args { # }\ # -fallback 1 # ... - # *parser -description "start 'count' count ??'by'? step?"\ + # @parser -synopsis "start 'count' count ??'by'? step?"\ # -arities { # {3 anykeys {1 count}} # } # ... - # *parser -description "count ?'by' step?"\ + # @form -synopsis "count ?'by' step?"\ # -arities { # 1 # {3 anykeys {1 by}} # } # # see also after manual - # *parser -arities {1} - # *parser -arities { + # @form -arities {1} + # @form -arities { # 1 anykeys {0 info} # } #todo - set parser_info $at_specs + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) } cmd { #allow arbitrary - review @@ -765,475 +953,644 @@ tcl::namespace::eval punk::args { set argdisplay_info [dict merge $argdisplay_info $at_specs] } opts { - if {$argspace eq "values"} { - error "punk::args::definition - @opts declaration must come before @values - received '$linespecs' id:$spec_id" - } - set argspace "options" - foreach {k v} $at_specs { - switch -- $k { - -any - - -anyopts { - set opt_any $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset optspec_defaults $k2 + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 } - none - "" - - - any - ansistring - globstring - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" } - tcl::dict::set optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set optspec_defaults $k $v - } - default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @opts line. Known keys: $known id:$spec_id" } } - } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids } leaders { - if {$argspace in [list options values]} { - error "punk::args::definition - @leaders declaration must come before all options and values id:$spec_id" - } - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$spec_id" + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} } - set leader_min $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$spec_id" + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v } - set leader_max $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset leaderspec_defaults $k2 + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" } - tcl::dict::set leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set leaderspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @leaders line. Known keys: $known @id:$spec_id" } } - } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids } values { - set argspace "values" - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$spec_id" - } - set val_min $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$spec_id" - } - set val_max $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegoups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset valspec_defaults $k2 + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" } - bool - boolean { - set v bool + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" } - dict - dictionary { - set v dict + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegoups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 } - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" } - tcl::dict::set valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @values line. Known keys: $known @id:$spec_id" } } + dict set F $fid valspec_defaults $tmp_valspec_defaults } } default { - error "punk::args::definition - unrecognised @ line in '$ln'. Expected @id @cmd @leaders @opts or @values - use @@name if paramname needs to be @name @id:$spec_id" + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" } } + #record_type directive continue } elseif {$firstchar eq "-"} { - if {$argspace eq "leaders"} { - set argspace "options" - } elseif {$argspace eq "values"} { - error "punk::args::definition - invalid placement of line '$ln' - must come before @values @id:$spec_id" - } - set argspecs $linespecs - tcl::dict::set argspecs -ARGTYPE option - lappend opt_names $argname + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + set is_opt 1 } else { + set argname $firstword if {$firstchar eq "@"} { #allow basic @@ escaping for literal argname that begins with @ set argname [tcl::string::range $argname 1 end] } - set argspecs $linespecs - if {$argspace eq "leaders"} { - tcl::dict::set argspecs -ARGTYPE leader - lappend leader_names $argname - if {$leader_max >= 0} { - set leader_max [llength $leader_names] + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname } - } else { - tcl::dict::set argspecs -ARGTYPE value - lappend val_names $argname } + set is_opt 0 } + + #assert - we only get here if it is a value or flag specification line. - #assert argspecs has been set to the value of linespecs - if {$is_opt} { - set spec_merged $optspec_defaults - } else { - if {$argspace eq "values"} { - set spec_merged $valspec_defaults + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] } else { - set spec_merged $leaderspec_defaults + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } } - } - foreach {spec specval} $argspecs { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { - tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" } - lappend opt_solos $argname - } else { - #-solo only valid for flags - error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname' @id:$spec_id" } - } - 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] + 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 - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$spec_id" + -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$spec_id" + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" } } - } - default { - set known_argspecs [list -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - ] - error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs @id:$spec_id" - } - } - } - set argspecs $spec_merged - if {$is_opt} { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } else { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set arg_info $argname $argspecs - tcl::dict::set arg_checks $argname $argchecks - #review existence of -default overriding -optional - if {![tcl::dict::get $argspecs -optional] && ![tcl::dict::exists $argspecs -default]} { + } ;# end foreach {spec specval} argdef_values + + if {$is_opt} { - lappend opt_required $argname + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } else { - if {$argspace eq "leaders"} { - lappend leader_required $argname + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname } else { - lappend val_required $argname + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } } } - } - if {[tcl::dict::exists $argspecs -default]} { - if {$is_opt} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $argspecs -default] - } else { - if {$argspace eq "leaders"} { - tcl::dict::set leader_defaults $argname [tcl::dict::get $argspecs -default] + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $argspecs -default] + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } } } - } - } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + - if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { + if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { variable id_counter - set spec_id "autoid_[incr id_counter]" - } - - # REVIEW - #if {[llength $val_names] || $val_min > 0} { - # #some values are specified - # foreach leadername [lrange $leader_names 0 end] { - # if {[tcl::dict::get $arg_info $leadername -multiple]} { - # error "bad key -multiple on argument spec for leader '$leadername'. Last leader argument specification can be marked -multiple only when no values are specified" - # } - # } - #} else { + set DEF_definition_id "autoid_[incr id_counter]" + } + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW #no values specified - we can allow last leader to be multiple - foreach leadername [lrange $leader_names 0 end-1] { - if {[tcl::dict::get $arg_info $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple @id:$spec_id" + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" } } - #} - #confirm any valnames before last don't have -multiple key - foreach valname [lrange $val_names 0 end-1] { - if {[tcl::dict::get $arg_info $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple @id:$spec_id" + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - set leader_checks_defaults [tcl::dict::remove $leaderspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } set argdata_dict [tcl::dict::create\ - id $spec_id\ - arg_info $arg_info\ - arg_checks $arg_checks\ - leader_defaults $leader_defaults\ - leader_required $leader_required\ - leader_names $leader_names\ - leader_min $leader_min\ - leader_max $leader_max\ - leaderspec_defaults $leaderspec_defaults\ - leader_checks_defaults $leader_checks_defaults\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - opt_names $opt_names\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults $optspec_defaults\ - opt_checks_defaults $opt_checks_defaults\ - val_defaults $val_defaults\ - val_required $val_required\ - val_names $val_names\ - val_min $val_min\ - val_max $val_max\ - valspec_defaults $valspec_defaults\ - val_checks_defaults $val_checks_defaults\ - cmd_info $cmd_info\ - doc_info $doc_info\ - argdisplay_info $argdisplay_info\ - id_info $id_info\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + argdisplay_info $argdisplay_info\ + id_info $id_info\ + temp_F $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ ] + tcl::dict::set argdata_cache $cache_key $argdata_dict if {$is_dynamic} { #also cache resolved version tcl::dict::set argdata_cache $optionspecs $argdata_dict } - #tcl::dict::set argdefcache_by_id $spec_id $optionspecs - tcl::dict::set argdefcache_by_id $spec_id $args + #tcl::dict::set argdefcache_by_id $DEF_definition_id $optionspecs + tcl::dict::set argdefcache_by_id $DEF_definition_id $args #puts "xxx:$result" return $argdata_dict } - proc get_spec {id {patternlist *}} { + lappend PUNKARGS [list -dynamic 0 { + @id -id ::punk::args::get_spec + @cmd -name punk::args::get_definition -help\ + "" + id -type string -help\ + "identifer for punk::args defintion + This will usually be a fully-qualifed + path for a command name" + patternlist -type list -optional 1 -default * -help\ + "glob-style patterns for retrieving value or switch + definitions. If ommitted or passed an empty string, + the raw unresolved definition will be returned as + a list, including possible leading flags such as + -dynamic 0|1. + If specified as * - the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + " + override_dict -type dict -optional 1 -default "" -help\ + "unimplemented. + Will allow overriding or adding flags to a returned + definition line. + " + }] + #rename get_definition ??? + proc get_spec {id args} { + lassign $args patternlist override_dict + if {[llength $args] > 2} { + punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args] + return + } + if {[llength $override_dict] % 2 != 0} { + #malformed dict + punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args] + return + } + variable argdefcache_by_id set realid [real_id $id] if {$realid ne ""} { - if {$patternlist eq "*"} { - #todo? + if {$patternlist eq ""} { + #return the raw definition - possibly with unresolved dynamic parts return [tcl::dict::get $argdefcache_by_id $realid] } else { - set speclist [tcl::dict::get $argdefcache_by_id $realid] + set deflist [tcl::dict::get $argdefcache_by_id $realid] set result "" - set specdict [uplevel 1 [list ::punk::args::definition {*}$speclist]] - set arg_info [dict get $specdict arg_info] + set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]] + set arg_info [dict get $specdict ARG_INFO] foreach pat $patternlist { + if {[string match $pat @id]} { + #only a single id record can exist + append result \n "@id -id [dict get $specdict id]" + } + if {[string match $pat @cmd]} { + #only a single @cmd record can exist + #merged if multiple in original def (?) + append result \n "@cmd [dict get $specdict cmd_info]" + } + #todo @leaders, @opts, @values lines + #can be multiple of each. We need to preserve order and interleave + #with any matching arg_info results. + #requires storing more info in the internal spec dictionary set matches [dict keys $arg_info $pat] foreach m $matches { set def [dict get $arg_info $m] @@ -1250,9 +1607,9 @@ tcl::namespace::eval punk::args { set realid [real_id $id] if {$realid ne ""} { set speclist [tcl::dict::get $argdefcache_by_id $realid] - set specdict [definition {*}$speclist] - set arg_info [dict get $specdict arg_info] - set valnames [dict get $specdict val_names] + set specdict [define {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] set result "" if {$patternlist eq "*"} { foreach v $valnames { @@ -1280,7 +1637,7 @@ tcl::namespace::eval punk::args { proc get_def {id} { if {[id_exists $id]} { - return [definition {*}[get_spec $id]] + return [define {*}[get_spec $id]] } } proc is_dynamic {id} { @@ -1374,8 +1731,8 @@ tcl::namespace::eval punk::args { #puts -nonewline stderr . ;#debugging - see actual loads if {![catch { if {[info exists ${pkgns}::PUNKARGS]} { - foreach deflist [set ${pkgns}::PUNKARGS] { - namespace eval $pkgns [list punk::args::definition {*}$deflist] + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $pkgns [list punk::args::define {*}$definitionlist] } } if {[info exists ${pkgns}::PUNKARGS_aliases]} { @@ -1432,9 +1789,113 @@ tcl::namespace::eval punk::args { return $cmdinfo } + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::get_spec ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -choices {nocolour info error} + }] ] + #basic recursion blocker variable arg_error_isrunning 0 proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + if {[catch {package require punk::ansi}]} { proc punk::args::a {args} {} proc punk::args::a+ {args} {} @@ -1458,8 +1919,9 @@ tcl::namespace::eval punk::args { set badarg "" set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error + set scheme error dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return} $k] + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] switch -- $fullk { -badarg { set badarg $v @@ -1471,6 +1933,9 @@ tcl::namespace::eval punk::args { } set as_error $v } + -scheme { + set scheme $v + } -return { if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { set arg_error_isrunning 0 @@ -1484,6 +1949,68 @@ tcl::namespace::eval punk::args { } } } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. @@ -1510,13 +2037,13 @@ tcl::namespace::eval punk::args { append errmsg \n } else { if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)[a]" \n } else { append errmsg \n } } - set procname [Dict_getdef $spec_dict cmd_info -name ""] - set prochelp [Dict_getdef $spec_dict cmd_info -help ""] + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] set docurl [Dict_getdef $spec_dict doc_info -url ""] @@ -1531,18 +2058,18 @@ tcl::namespace::eval punk::args { set blank_header_col [list] - if {$procname ne ""} { + if {$cmdname ne ""} { lappend blank_header_col "" - set procname_display [a+ brightwhite]$procname[a] + set cmdname_display $CLR(cmdname)$cmdname[a] } else { - set procname_display "" + set cmdname_display "" } - if {$prochelp ne ""} { + if {$cmdhelp ne ""} { lappend blank_header_col "" - #set prochelp_display [a+ brightwhite]$prochelp[a] - set prochelp_display [textblock::ansibase_lines $prochelp [a+ white]] + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] } else { - set prochelp_display "" + set cmdhelp_display "" } if {$docurl ne ""} { lappend blank_header_col "" @@ -1550,11 +2077,25 @@ tcl::namespace::eval punk::args { } else { set docurl_display "" } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + if {$argdisplay_header ne ""} { lappend blank_header_col "" } if {$use_table} { - set t [textblock::class::table new [a+ brightyellow]Usage[a]] + set t [textblock::class::table new $CLR(title)Usage[a]] $t add_column -headers $blank_header_col -minwidth 3 $t add_column -headers $blank_header_col @@ -1573,19 +2114,19 @@ tcl::namespace::eval punk::args { } } set h 0 - if {$procname ne ""} { + if {$cmdname ne ""} { if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list PROC/METHOD: $procname_display] + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] } else { - lappend errlines "PROC/METHOD: $procname_display" + lappend errlines "COMMAND: $cmdname_display" } incr h } - if {$prochelp ne ""} { + if {$cmdhelp ne ""} { if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $prochelp_display] + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] } else { - lappend errlines "Description: $prochelp_display" + lappend errlines "Description: $cmdhelp_display" } incr h } @@ -1600,6 +2141,17 @@ tcl::namespace::eval punk::args { } incr h } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + if {$use_table} { if {$is_custom_argdisplay} { if {$argdisplay_header ne ""} { @@ -1632,11 +2184,13 @@ tcl::namespace::eval punk::args { set RST [a] #set A_DEFAULT [a+ brightwhite Brightgreen] set A_DEFAULT "" - set A_BADARG [a+ brightred] - set greencheck [a+ brightgreen]\u2713[a] ;#green tick - set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX [a+ green] ;#use a+ so colour off can apply - if {$A_PREFIX eq ""} { + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713[a] ;#green tick + set soloflag $CLR(solo)\u2690[a] ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead set A_PREFIX [a+ underline] set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space } else { @@ -1645,14 +2199,14 @@ tcl::namespace::eval punk::args { set opt_names [list] set opt_names_display [list] - if {[llength [dict get $spec_dict opt_names]]} { + 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 trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] set idents [dict get [$trie shortest_idents ""] scanned] #todo - check opt_prefixdeny $trie destroy - foreach c [dict get $spec_dict opt_names] { + foreach c [dict get $spec_dict OPT_NAMES] { set id [dict get $idents $c] #REVIEW if {$id eq $c} { @@ -1668,12 +2222,12 @@ tcl::namespace::eval punk::args { lappend opt_names $c } } else { - set opt_names [dict get $spec_dict opt_names] + set opt_names [dict get $spec_dict OPT_NAMES] set opt_names_display $opt_names } } - set leading_val_names [dict get $spec_dict leader_names] - set trailing_val_names [dict get $spec_dict val_names] + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { # if {![string match -* $argname]} { @@ -1695,7 +2249,7 @@ tcl::namespace::eval punk::args { lassign $argumentset argnames_display argnames foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict arg_info $arg] + set arginfo [dict get $spec_dict ARG_INFO $arg] if {[dict exists $arginfo -default]} { set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { @@ -1707,6 +2261,13 @@ tcl::namespace::eval punk::args { set choicegroups [Dict_getdef $arginfo -choicegroups {}] set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } if {[dict exists $choicegroups ""]} { dict lappend choicegroups "" {*}$choices } else { @@ -1827,12 +2388,11 @@ tcl::namespace::eval punk::args { #TODO -title directly in list_as_table set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] lappend choicetable_objects $choicetableobj - $choicetableobj configure -title [a+ cyan]$groupname + $choicetableobj configure -title $CLR(groupname)$groupname #append help \n[textblock::join -- " " [$choicetableobj print]] } else { if {$groupname ne ""} { - #bold as well as brightcolour in case colour off. - append help \n \n "[a+ brightyellow bold]Group: $groupname[a]" + append help \n \n "$CLR(groupname)Group: $groupname[a]" } else { append help \n } @@ -1846,15 +2406,15 @@ tcl::namespace::eval punk::args { if {$usetable} { #these will be displayed after all table entries if {$groupname eq ""} { - dict set choicetable_footers "" " [a+ red](no choices defined for main group)[a]" + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)[a]" } else { - dict set choicetable_footers $groupname " [a+ red](no choices defined for group $groupname)[a]" + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)[a]" } } else { if {$groupname eq ""} { - append help \n " " [a+ red](no choices defined)[a] + append help \n " " $CLR(errormsg)(no choices defined)[a] } else { - append help \n " " [a+ red](no choices defined for group $groupname)[a] + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)[a] } } } @@ -1896,13 +2456,16 @@ tcl::namespace::eval punk::args { } } } - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - set argshow "?${argshow}?" + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } } set typeshow [dict get $arginfo -type] if {$typeshow eq "none"} { @@ -1936,7 +2499,13 @@ tcl::namespace::eval punk::args { } ;#end is_custom_argdisplay if {$use_table} { - $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + $t configure -maxwidth 80 ;#review if {$returntype ne "tableobject"} { append errmsg [$t print] @@ -1976,7 +2545,7 @@ tcl::namespace::eval punk::args { } - lappend PUNKARGS [list { + lappend PUNKARGS [list -dynamic 1 { @id -id ::punk::args::usage @cmd -name punk::args::usage -help\ "Return usage information for a command. @@ -1989,6 +2558,7 @@ tcl::namespace::eval punk::args { mechanism and call this as necessary. " -return -default table -choices {string table tableobject} + } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} { @values -min 0 -max 1 id -help\ @@ -1998,11 +2568,12 @@ tcl::namespace::eval punk::args { proc usage {args} { lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received set id [dict get $values id] - set speclist [get_spec $id] - if {[llength $speclist] == 0} { + set definitionlist [get_spec $id] + if {[llength $definitionlist] == 0} { error "punk::args::usage - no such id: $id" } - arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] {*}$opts -aserror 0 + #by placing scheme before the supplied args - it can be overridden + arg_error "" [uplevel 1 [list punk::args::define {*}$definitionlist]] -scheme punk_info {*}$opts -aserror 0 } lappend PUNKARGS [list { @@ -2010,16 +2581,150 @@ tcl::namespace::eval punk::args { @cmd -name punk::args::get_by_id @values -min 1 id - arglist -default "" -type list -help\ + arglist -type list -help\ "list containing arguments to be parsed as per the argument specification identified by the supplied id." }] - proc get_by_id {id {arglist ""}} { - set speclist [punk::args::get_spec $id] - if {[llength $speclist] == 0} { + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::get_spec $id] + if {[llength $definitionlist] == 0} { error "punk::args::get_by_id - no such id: $id" } - return [uplevel 1 [list ::punk::args::get_dict {*}$speclist $arglist]] + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing + record that has been created with ::punk::args::define. + In the 'withdef' form - the definition is created on the + first call and cached thereafter. + + form1: parse ?-flag val?... -- $arglist withid $id + form2: parse ?-flag val?... -- $arglist withdef $def ?$def? + see punk::args::define" + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries. + " + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard minimal} + @values -min 3 + sep -optional 0 -choices "--" + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + set split [lsearch -exact $args --] ;#first -- + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. End of opts marker -- is required even if no options are present." + } + set opts [lrange $args 0 $split-1] ;#repeated flags will override earlier. That's ok here. + set arglist [lindex $args $split+1] + set tailtype [lindex $args $split+2] + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $args $split+3 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $split+3] + return "parse [llength $arglist] args withid $id, options:$opts" + } + withdef { + if {[llength [lrange $args $split+3 end]] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO } #todo? - a version of get_dict that directly supports punk::lib::tstr templating @@ -2031,6 +2736,15 @@ tcl::namespace::eval punk::args { #only supports -flag val pairs, not solo options #If an option is supplied multiple times - only the last value is used. proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + #*** !doctools #[call [fun get_dict] [arg optionspecs] [arg rawargs]] #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values @@ -2065,54 +2779,26 @@ tcl::namespace::eval punk::args { # @values -multiple 1 #} $args - #if {[llength $args] == 0} { - # set rawargs [list] - #} elseif {[llength $args] ==1} { - # set rawargs [lindex $args 0] ;#default tcl style - #} else { - # #todo - can we support tk style vals before flags? - # #the aim is to allow a single call to validate standard leading proc positional args along with the $args val which may have flags in tk or tcl order - # #by allowing all to be in a single call - we could use a -help (or similar erroring call) to trigger the spec-parsing from a wrapper function. - # #this would be important in the case where the function to be wrapped has never been called - but the wrapper needs info about the downstream options - # #we would like to avoid the ugliness of trying to parse a proc body to scrape the specification. - # #we may still need to do a basic scan of the proc body to determine if it at least contains the string punk::args::get_dict - but that is slightly less odious. - # error "unsupported number of arguments for punk::args::get_dict" - # set inopt 0 - # set k "" - # set i 0 - # foreach a $args { - # switch -- $f { - # -opts { - - # } - # -vals { - - # } - # -optvals { - # #tk style - - # } - # -valopts { - # #tcl style - # set rawargs [lindex $args $i+1] - # incr i - # } - # default { - - # } - # } - # incr i - # } - #} set is_dynamic 0 if {[lindex $args 0] eq "-dynamic"} { set is_dynamic [lindex $args 1] } set rawargs [lindex $args end] ;# args values to be parsed - set def_args [lrange $args 0 end-1] - set argspecs [uplevel 1 [list ::punk::args::definition {*}$def_args]] + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::define {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + #puts "-arg_info->$arg_info" set flagsreceived [list] ;#for checking if required flags satisfied #secondary purpose: @@ -2128,31 +2814,31 @@ tcl::namespace::eval punk::args { set opts $opt_defaults set pre_values {} - set argnames [tcl::dict::keys $arg_info] + set argnames [tcl::dict::keys $ARG_INFO] set optnames [lsearch -all -inline $argnames -*] set ridx 0 set rawargs_copy $rawargs set leader_posn_name "" set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) set is_multiple 0 ;#last leader may be multi - if {$leader_max != 0} { + if {$LEADER_MAX != 0} { foreach r $rawargs_copy { - if {$leader_max ne "" && $leader_max != -1 && $ridx > $leader_max-1} { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { break } - if {$ridx == [llength $leader_names]-1} { + if {$ridx == [llength $LEADER_NAMES]-1} { #at last named leader - set leader_posn_name [lindex $leader_names $ridx] - if {[dict exists $arg_info $leader_posn_name -multiple] && [dict get $arg_info $leader_posn_name -multiple]} { + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { set is_multiple 1 } - } elseif {$ridx > [llength $leader_names]-1} { + } elseif {$ridx > [llength $LEADER_NAMES]-1} { #beyond names - retain name if -multiple was true if {!$is_multiple} { set leader_posn_name "" } } else { - set leader_posn_name [lindex $leader_names $ridx] ;#may return empty string + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string } if {$r eq "--"} { #review end of opts marker: '--' can't be a leader (but can be a value) @@ -2181,7 +2867,7 @@ tcl::namespace::eval punk::args { #for each branch - break or lappend if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $leader_required} { + if {$leader_posn_name ni $LEADER_REQUIRED} { #optional leader #most adhoc arg processing will allocate based on number of args rather than matching choice values first @@ -2220,11 +2906,11 @@ tcl::namespace::eval punk::args { } } else { #unnamed leader - if {$leader_min ne "" } { - if {$ridx > $leader_min} { + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { break } else { - #haven't reached leader_min + #haven't reached LEADER_MIN lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } @@ -2234,16 +2920,24 @@ tcl::namespace::eval punk::args { } incr ridx - } + } ;# end foreach r $rawargs_copy } - if {$leader_min eq ""} { - set leader_min 0 + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN } - if {$leader_max eq ""} { - set leader_max -1 + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX } - #assert leader_max leader_min are numeric + #assert leadermax leadermin are numeric #assert - rawargs has been reduced by leading positionals set leaders [list] @@ -2251,7 +2945,7 @@ tcl::namespace::eval punk::args { set post_values {} #val_min, val_max #puts stderr "rawargs: $rawargs" - #puts stderr "arg_info: $arg_info" + #puts stderr "argstate: $argstate" if {[lsearch $rawargs -*] >= 0} { #at least contains flaglike things.. set maxidx [expr {[llength $rawargs] -1}] @@ -2298,9 +2992,9 @@ tcl::namespace::eval punk::args { } break } else { - set fullopt [tcl::prefix match -error "" $opt_names $a] + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] if {$fullopt ne ""} { - if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { #non-solo #check if it was actually a value that looked like a flag if {$i == $maxidx} { @@ -2312,7 +3006,7 @@ tcl::namespace::eval punk::args { } set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $argstate $fullopt -multiple]} { #don't lappend to default - we need to replace if there is a default if {$fullopt ni $flagsreceived} { tcl::dict::set opts $fullopt [list $flagval] @@ -2329,7 +3023,7 @@ tcl::namespace::eval punk::args { } } else { #solo - if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $argstate $fullopt -multiple]} { if {$fullopt ni $flagsreceived} { #override any default - don't lappend to it tcl::dict::set opts $fullopt 1 @@ -2359,10 +3053,10 @@ tcl::namespace::eval punk::args { if {$opt_any} { set newval [lindex $rawargs $i+1] #opt was unspecified but is allowed due to @opts -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::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { tcl::dict::lappend opts $a $newval } else { tcl::dict::set opts $a $newval @@ -2373,7 +3067,7 @@ tcl::namespace::eval punk::args { 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::get $argstate $a -multiple]} { if {![tcl::dict::exists $opts $a]} { tcl::dict::set opts $a 1 } else { @@ -2386,8 +3080,8 @@ tcl::namespace::eval punk::args { } lappend flagsreceived $a ;#adhoc flag as supplied } else { - if {[llength $opt_names]} { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" + if {[llength $OPT_NAMES]} { + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" } else { set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" } @@ -2419,15 +3113,15 @@ tcl::namespace::eval punk::args { set ldridx 0 set in_multiple "" set leadernames_received [list] - set leaders_dict $leader_defaults + set leaders_dict $LEADER_DEFAULTS set num_leaders [llength $leaders] - foreach leadername $leader_names ldr $leaders { + foreach leadername $LEADER_NAMES ldr $leaders { if {$ldridx+1 > $num_leaders} { break } if {$leadername ne ""} { - if {[tcl::dict::get $arg_info $leadername -multiple]} { - if {[tcl::dict::exists $leader_defaults $leadername]} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list } else { tcl::dict::lappend leaders_dict $leadername $ldr @@ -2443,8 +3137,8 @@ tcl::namespace::eval punk::args { lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) } else { tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set arg_info $positionalidx $leaderspec_defaults - tcl::dict::set arg_checks $positionalidx $leader_checks_defaults + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS lappend leadernames_received $positionalidx } } @@ -2457,12 +3151,12 @@ tcl::namespace::eval punk::args { set valnames_received [list] set values_dict $val_defaults set num_values [llength $values] - foreach valname $val_names val $values { + foreach valname $VAL_NAMES val $values { if {$validx+1 > $num_values} { break } if {$valname ne ""} { - if {[tcl::dict::get $arg_info $valname -multiple]} { + if {[tcl::dict::get $argstate $valname -multiple]} { if {[tcl::dict::exists $val_defaults $valname]} { #current stored val equals defined default - don't include default in the list we build up tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list @@ -2481,8 +3175,8 @@ tcl::namespace::eval punk::args { lappend valnames_received $in_multiple } else { tcl::dict::set values_dict $positionalidx $val - tcl::dict::set arg_info $positionalidx $valspec_defaults - tcl::dict::set arg_checks $positionalidx $val_checks_defaults + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS lappend valnames_received $positionalidx } } @@ -2490,17 +3184,17 @@ tcl::namespace::eval punk::args { incr positionalidx } - if {$leader_max == -1} { + if {$leadermax == -1} { #only check min - if {$num_leaders < $leader_min} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leader_min" $argspecs + if {$num_leaders < $leadermin} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs } } else { - if {$num_leaders < $leader_min || $num_leaders > $leader_max} { - if {$leader_min == $leader_max} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leader_min" $argspecs + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs } else { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leader_min and $leader_max inclusive" $argspecs + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs } } } @@ -2541,7 +3235,7 @@ tcl::namespace::eval punk::args { # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $leader_required $leadernames_received]]]} { + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs } if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { @@ -2560,9 +3254,9 @@ tcl::namespace::eval punk::args { set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash #puts "---opts_and_values:$opts_and_values" - #puts "---arg_info:$arg_info" + #puts "---argstate:$argstate" tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $arg_info $argname] + set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] set thisarg_checks [tcl::dict::get $arg_checks $argname] set is_multiple [tcl::dict::get $thisarg -multiple] @@ -3471,10 +4165,10 @@ tcl::namespace::eval punk::args::lib { #for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. #arguably it may be more processor-cache-efficient to do together like this anyway. -#can't do this - as there is circular dependency with punk::lib +#can't do this here? - as there is circular dependency with punk::lib #tcl::namespace::eval punk::args { # foreach deflist $PUNKARGS { -# punk::args::definition {*}$deflist +# punk::args::define {*}$deflist # } # set PUNKARGS "" #} diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm index 3024053b..8cb06b1f 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm @@ -1246,6 +1246,10 @@ tcl::namespace::eval punk::char { return [charset_dict "Box Drawing"] } + proc char_hex {char} { + return [format %08x [scan $char %c]] + } + proc char_info_hex {hex args} { set hex [tcl::string::map [list _ ""] $hex] if {[tcl::string::is xdigit -strict $hex]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index d2c08e8b..74365afa 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -1186,7 +1186,7 @@ namespace eval punk::console { #todo - change -inoutchannels to -terminalobject with prebuilt default - punk::args::definition { + punk::args::define { @id -id ::punk::console::cell_size -inoutchannels -default {stdin stdout} -type list @values -min 0 -max 1 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm index 6de20bff..1f02859b 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -1251,7 +1251,7 @@ namespace eval punk::fileline { #[para] Core API functions for punk::fileline #[list_begin definitions] - punk::args::definition { + punk::args::define { @id -id ::punk::fileline::get_textinfo @cmd -name punk::fileline::get_textinfo -help\ "return: textinfo object instance" diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index f427f29f..b5539021 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -26,7 +26,7 @@ package require punk::lib namespace eval punk::mix::commandset::loadedlib { namespace export * #search automatically wrapped in * * - can contain inner * ? globs - punk::args::definition { + punk::args::define { @id -id ::punk::mix::commandset::loadedlib::search @cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" -return -type string -default table -choices {table tableobject list lines} diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index 2079eb8c..41206d0c 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -141,7 +141,7 @@ namespace eval punk::mix::commandset::module { set moduletypes [punk::mix::cli::lib::module_types] - punk::args::definition [subst { + punk::args::define [subst { @id -id ::punk::mix::commandset::module::new @cmd -name "punk::mix::commandset::module::new" -help\ "Create a new module file in the appropriate folder within src/modules. diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 3f5f3a71..5d601b3a 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -636,7 +636,7 @@ tcl::namespace::eval punk::nav::fs { # c:/repo/jn/punk/../../blah #dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold # dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream - punk::args::definition { + punk::args::define { @id -id ::punk::nav::fs::dirfiles -stripbase -default 1 -type boolean -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" @@ -992,7 +992,7 @@ tcl::namespace::eval punk::nav::fs { return [dict merge $listing $updated] } - punk::args::definition { + punk::args::define { @id -id ::punk::nav::fs::dirfiles_dict_as_lines -stripbase -default 0 -type boolean -formatsizes -default 1 -type boolean diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index f8a1e939..6235224a 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -1893,7 +1893,31 @@ tcl::namespace::eval punk::ns { } } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} $vline" set idauto "(autodef)$origin" - set argspec [punk::lib::tstr -return string { + set argdef [punk::lib::tstr -return string { @id -id ${$idauto} @cmd -name "Object: ${$origin}" -help\ "Instance of class: ${$class} (info autogenerated)" @values -min 1 }] - append argspec \n $vline - punk::args::definition $argspec + append argdef \n $vline + punk::args::define $argdef return [punk::args::usage {*}$opts $idauto] } privateObject { @@ -2457,7 +2502,8 @@ tcl::namespace::eval punk::ns { set match [tcl::prefix::match $subcommands [lindex $queryargs 0]] if {$match in $subcommands} { set subcmd [dict get $subcommand_dict $match] - return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + return [arginfo {*}$opts {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") } } @@ -2491,15 +2537,15 @@ tcl::namespace::eval punk::ns { set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] set autoid "(autodef)$origin" - set argspec [punk::lib::tstr -return string { + set argdef [punk::lib::tstr -return string { @id -id ${$autoid} @cmd -help\ "(autogenerated) ensemble: ${$origin}" @values -min 1 }] - append argspec \n $vline - punk::args::definition $argspec + append argdef \n $vline + punk::args::define $argdef return [punk::args::usage {*}$opts $autoid] } @@ -2918,7 +2964,7 @@ tcl::namespace::eval punk::ns { } interp alias "" use "" punk::ns::pkguse - punk::args::definition { + punk::args::define { @id -id ::punk::ns::nsimport_noclobber @cmd -name punk::ns::nsimport_noclobber -help\ "Import exported commands from a namespace into either the current namespace, diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index 65ede7c8..ede3e18b 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -644,7 +644,7 @@ namespace eval punk::path { return $ismatch } - punk::args::definition { + punk::args::define { @id -id ::punk::path::treefilenames -directory -type directory -help\ "folder in which to begin recursive scan for files." diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index 98bc04ef..063a13c0 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -65,6 +65,22 @@ namespace eval punk::repo { variable PUNKARGS variable PUNKARGS_aliases + variable cached_command_paths + set cached_command_paths [dict create] + #anticipating possible removal of buggy caching from auto_execok + #mentioned in: https://core.tcl-lang.org/tcl/tktview/4dc35e0c0c + #this would leave the application to decide what it wants to cache in that regard. + proc Cached_auto_execok {name} { + return [auto_execok $name] + #variable cached_command_paths + #if {[dict exists $cached_command_paths $name]} { + # return [dict get $cached_command_paths $name] + #} + #set resolved [auto_execok $name] + #dict set cached_command_paths $name $resolved + #return $resolved + } + proc get_fossil_usage {} { set allcmds [runout -n fossil help -a] set mainhelp [runout -n fossil help] @@ -197,7 +213,7 @@ namespace eval punk::repo { #emit warning whether or not multiple fossil repos puts stdout [dict get $repostate warnings] } - set fossil_prog [auto_execok fossil] + set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog ne ""} { {*}$fossil_prog {*}$args } else { @@ -222,7 +238,10 @@ namespace eval punk::repo { #uppercase FOSSIL to bypass fossil as alias to fossil_proxy + #only necessary on unix? + #Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway proc establish_FOSSIL {args} { + #review if {![info exists ::auto_execs(FOSSIL)]} { set ::auto_execs(FOSSIL) [auto_execok fossil] ;#may fail in safe interp } @@ -499,7 +518,7 @@ namespace eval punk::repo { #For this reason we will store 'unchanged' records for both git and fossil so that the combined dict should represent all files in the revision if {$rt eq "fossil"} { dict set resultdict repotype fossil - set fossil_cmd [auto_execok fossil] + set fossil_cmd [Cached_auto_execok fossil] if {$fossil_cmd eq ""} { error "workingdir_state error: fossil executable doesn't seem to be available" } @@ -598,7 +617,7 @@ namespace eval punk::repo { break } elseif {$rt eq "git"} { dict set resultdict repotype git - set git_cmd [auto_execok git] + set git_cmd [Cached_auto_execok git] # -uno = suppress ? lines. # -b = show ranch and tracking info #our basic parsing/grepping assumes --porcelain=2 @@ -988,7 +1007,7 @@ namespace eval punk::repo { } proc fossil_get_repository_file {{path {}}} { if {$path eq {}} { set path [pwd] } - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set fossilinfo [::exec {*}$fossilcmd info] @@ -1073,7 +1092,7 @@ namespace eval punk::repo { set startdir $opt_parentfolder - set fossil_prog [auto_execok fossil] + set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog eq ""} { puts stderr "Fossil not found. Please install fossil" return @@ -1319,7 +1338,7 @@ namespace eval punk::repo { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[Cached_auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } @@ -1332,7 +1351,7 @@ namespace eval punk::repo { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[Cached_auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } @@ -1343,7 +1362,7 @@ namespace eval punk::repo { proc fossil_revision {{path {}}} { if {$path eq {}} { set path [pwd] } # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set info [::exec {*}$fossilcmd info] @@ -1357,7 +1376,7 @@ namespace eval punk::repo { proc fossil_remote {{path {}}} { if {$path eq {}} { set path [pwd] } # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set info [::exec {*}$fossilcmd remote ls] @@ -1423,7 +1442,7 @@ namespace eval punk::repo { set original_cwd [pwd] #attempt2 - let fossil do it for us - hopefully based on current folder if {$path eq {}} {set path [pwd]} - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {![llength $fossilcmd]} { set fossil_ok 0 } else { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm index dcc023ec..a3d5b967 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm @@ -8367,7 +8367,7 @@ tcl::namespace::eval textblock { foreach tline $tlines { if {[tcl::string::first $FSUB $tline] >= 0} { set content_line [lindex $clines $contentindex] - if {[tcl::string::first $R $content_line] == 0} { + if {[tcl::string::first $R [string range $content_line 0 10]] == 0} { set content_line [tcl::string::range $content_line $rlen end] } #make sure to replay opt_ansibase to the right of the replacement diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm new file mode 100644 index 00000000..32450e55 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -0,0 +1,8567 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix 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. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application textblock 0.1.3 +# Meta platform tcl +# Meta license +# @@ Meta End + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_textblock 0 0.1.3] +#[copyright "2024"] +#[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 ansi text layout colour table frame console terminal] +#[description] +#[para] Ansi-aware terminal textblock manipulation + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of textblock +#[subsection Concepts] +#[para] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by textblock +#[list_begin itemized] + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] +#[item] [package {punk::char}] +#[item] [package {punk::ansi}] +#[item] [package {punk::lib}] +#[item] [package {overtype}] +#[item] [package {term::ansi::code::macros}] +#[item] [package {textutil}] + +## Requirements +package require Tcl 8.6- +package require punk::args +package require punk::char +package require punk::ansi +package require punk::lib +catch {package require patternpunk} +package require overtype + +#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. +if {[catch { + package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? +} errM]} { + #catch this too in case stderr not available + catch { + puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM" + } +} +package require textutil + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval textblock { + #review - what about ansi off in punk::console? + tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ + tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock + + #NOTE sha1, although computationally more intensive, tends to be faster than md5 on modern cpus + #(more likely to be optimised for modern cpu features?) + #(This speed improvement may not apply for short strings) + + variable use_hash ;#framecache + set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display + #if {![catch {package require sha1}]} { + # set use_hash sha1 + #} elseif {![catch {package require md5}]} { + # set use_hash md5 + #} else { + # set use_hash none + #} + + proc use_hash {args} { + set choices [list none] + set unavailable [list] + set pkgs [package names] + if {"md5" in $pkgs} { + lappend choices md5 + } else { + lappend unavailable md5 + } + if {"sha1" in $pkgs} { + lappend choices sha1 + } else { + lappend unavailable sha1 + } + set choicemsg "" + if {[llength $unavailable]} { + set choicemsg " (unavailable packages: $unavailable)" + } + set argd [punk::args::get_dict [tstr -return string { + @id -id ::textblock::use_hash + @cmd -name "textblock::use_hash" -help\ + "Hashing algorithm to use for framecache lookup. + 'none' may be slightly faster but less compact + when viewing textblock::framecache" + @values -min 0 -max 1 + hash_algorithm -choices {${$choices}} -optional 1 -help\ + "algorithm choice ${$choicemsg}" + }] $args] + variable use_hash + if {![dict exists $argd received hash_algorithm]} { + return $use_hash + } + set use_hash [dict get $argd values hash_algorithm] + } + tcl::namespace::eval class { + variable opts_table_defaults + set opts_table_defaults [tcl::dict::create\ + -title ""\ + -titlealign "left"\ + -titletransparent 0\ + -frametype "light"\ + -frametype_header ""\ + -ansibase_header ""\ + -ansibase_body ""\ + -ansibase_footer ""\ + -ansiborder_header ""\ + -ansiborder_body ""\ + -ansiborder_footer ""\ + -ansireset "\uFFeF"\ + -framelimits_header "vll vlr hlb hlt tlc trc blc brc"\ + -frametype_body ""\ + -framelimits_body "vll vlr hlb hlt tlc trc blc brc"\ + -framemap_body [list\ + topleft {} topinner {} topright {} topsolo {}\ + middleleft {} middleinner {} middleright {} middlesolo {}\ + bottomleft {} bottominner {} bottomright {} bottomsolo {}\ + onlyleft {} onlyinner {} onlyright {} onlysolo {}\ + ]\ + -framemap_header [list\ + topleft {} topinner {} topright {} topsolo {}\ + middleleft {} middleinner {} middleright {} middlesolo {}\ + bottomleft {} bottominner {} bottomright {} bottomsolo {}\ + onlyleft {} onlyinner {} onlyright {} onlysolo {}\ + ]\ + -show_edge 1\ + -show_seps 1\ + -show_hseps ""\ + -show_vseps ""\ + -show_header ""\ + -show_footer ""\ + -minwidth ""\ + -maxwidth ""\ + ] + variable opts_column_defaults + set opts_column_defaults [tcl::dict::create\ + -headers [list]\ + -header_colspans [list]\ + -footers [list]\ + -defaultvalue ""\ + -ansibase ""\ + -ansireset "\uFFEF"\ + -minwidth ""\ + -maxwidth ""\ + -blockalign centre\ + -textalign left\ + ] + #initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only + + + + #for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns) + #ie only vll,blc,hlb used for cells except top row and right column + #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) + #right cells use 'U' shape (vll,blc,hlb,brc,vlr) + #e.g for 4x4 + # C C C O + # L L L U + # L L L U + #anti-clockwise elements + set C [list hlt tlc vll blc hlb] + set O [list trc hlt tlc vll blc hlb brc vlr] + set L [list vll blc hlb] + set U [list vll blc hlb brc vlr] + set tops [list trc hlt tlc] + set lefts [list tlc vll blc] + set bottoms [list blc hlb brc] + set rights [list trc brc vlr] + + variable table_edge_parts + set table_edge_parts [tcl::dict::create\ + topleft [struct::set intersect $C [concat $tops $lefts]]\ + 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]\ + middleinner [list]\ + middleright [struct::set intersect $U $rights]\ + middlesolo [struct::set intersect $U [concat $lefts $rights]]\ + bottomleft [struct::set intersect $L [concat $lefts $bottoms]]\ + bottominner [struct::set intersect $L $bottoms]\ + bottomright [struct::set intersect $U [concat $bottoms $rights]]\ + bottomsolo [struct::set intersect $U [concat $lefts $bottoms $rights]]\ + onlyleft [struct::set intersect $C [concat $tops $lefts $bottoms]]\ + onlyinner [struct::set intersect $C [concat $tops $bottoms]]\ + onlyright [struct::set intersect $O [concat $tops $bottoms $rights]]\ + onlysolo [struct::set intersect $O [concat $tops $lefts $bottoms $rights]]\ + ] + + #for header rows - we don't consider the bottom border as part of the edge - even if table body has no rows + #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 [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 [list {*}$lefts {*}$rights]]\ + bottomleft [struct::set intersect $L $lefts]\ + bottominner [list]\ + bottomright [struct::set intersect $U $rights]\ + 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 [list {*}$tops {*}$rights]]\ + onlysolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ + ] + variable table_hseps + set table_hseps [tcl::dict::create\ + topleft [list blc hlb]\ + topinner [list blc hlb]\ + topright [list blc hlb brc]\ + topsolo [list blc hlb brc]\ + middleleft [list blc hlb]\ + middleinner [list blc hlb]\ + middleright [list blc hlb brc]\ + middlesolo [list blc hlb brc]\ + bottomleft [list]\ + bottominner [list]\ + bottomright [list]\ + bottomsolo [list]\ + onlyleft [list]\ + onlyinner [list]\ + onlyright [list]\ + onlysolo [list]\ + ] + variable table_vseps + set table_vseps [tcl::dict::create\ + topleft [list]\ + topinner [list vll tlc blc]\ + topright [list vll tlc blc]\ + topsolo [list]\ + middleleft [list]\ + middleinner [list vll tlc blc]\ + middleright [list vll tlc blc]\ + middlesolo [list]\ + bottomleft [list]\ + bottominner [list vll tlc blc]\ + bottomright [list vll tlc blc]\ + bottomsolo [list]\ + onlyleft [list]\ + onlyinner [list vll tlc blc]\ + onlyright [list vll tlc blc]\ + onlysolo [list]\ + ] + + #ensembles seem to be not compiled in safe interp + #https://core.tcl-lang.org/tcl/tktview/1095bf7f75 + #as we want textblock to be usable in safe interps - use tcl::dict::for as a partial workaround + #This at least means the script argument, especially switch statements can get compiled. + #It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp. + + #e.g $t configure -framemap_body [table_edge_map " "] + + # -- --- --- --- --- + #unused? + proc table_edge_map {char} { + variable table_edge_parts + set map [list] + tcl::dict::for {celltype parts} $table_edge_parts { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + proc table_sep_map {char} { + variable table_hseps + set map [list] + tcl::dict::for {celltype parts} $table_hseps { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + proc header_edge_map {char} { + variable header_edge_parts + set map [list] + tcl::dict::for {celltype parts} $header_edge_parts { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + # -- --- --- --- --- + + if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} { + #*** !doctools + #[subsection {Namespace textblock::class}] + #[para] class definitions + #[list_begin itemized] [comment {- textblock::class groupings -}] + # [item] + # [para] [emph {handler_classes}] + # [list_begin enumerated] + + #this makes new table objects a little faster when multiple opts specified as well as to configure + #as tables are a heavyweight thing, but handy to nest sometimes - we'll take what we can get + set topt_keys [tcl::dict::keys $::textblock::class::opts_table_defaults] + set switch_keys_valid_topts [punk::lib::lmapflat v $topt_keys {list $v -}] + set switch_keys_valid_topts [lrange $switch_keys_valid_topts 0 end-1] ;#remove last dash + + set copt_keys [tcl::dict::keys $::textblock::class::opts_column_defaults] + set switch_keys_valid_copts [punk::lib::lmapflat v $copt_keys {list $v -}] + 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. + + variable o_columndefs + variable o_columndata + variable o_columnstates + variable o_headerdefs + variable o_headerstates + + variable o_rowdefs + variable o_rowstates + + variable o_opts_table_defaults + variable o_opts_header_defaults ;# header data mostly stored in o_columndefs + variable o_opts_column_defaults + variable o_opts_row_defaults + variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap) + variable o_calculated_column_widths + variable o_column_width_algorithm + + + 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 + + + if {[llength $args] == 1} { + set args [list -title [lindex $args 0]] + } + if {[llength $args] %2 !=0} { + error "[tcl::namespace::current]::table constructor - unexpected argument count. Require single value being title, or name value pairs" + } + + set o_opts_table $o_opts_table_defaults + set o_opts_table_effective $o_opts_table_defaults + + ##todo - test with punk::lib::show_jump_tables - how? + foreach {k v} $args { + switch -- $k { + %topt_switchkeys% { + tcl::dict::set o_opts_table $k $v + } + default { + error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + } + + #foreach {k v} $args { + # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. + # if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { + # error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + # } + #} + #set o_opts_table [tcl::dict::merge $o_opts_table_defaults $args] + #my configure {*}[tcl::dict::merge $o_opts_table_defaults $args] + + set o_columndefs [tcl::dict::create] + set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row + set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly + set o_headerdefs [tcl::dict::create] ;#by header-row + set o_headerstates [tcl::dict::create] + set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight + set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data + + set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices. + set o_calculated_column_widths [list] + set o_column_width_algorithm "span" + set o_opts_header_defaults [tcl::dict::create\ + -colspans {}\ + -values {}\ + -ansibase {}\ + -ansireset "\x1b\[m"\ + -minheight 1\ + -maxheight ""\ + ] + my configure {*}$o_opts_table + } + + method width_algorithm {{alg ""}} { + if {$alg eq ""} { + return $o_column_width_algorithm + } + if {$alg ne $o_column_width_algorithm} { + #invalidate cached widths + set o_calculated_column_widths [list] + } + set o_column_width_algorithm $alg + } + method Get_seps {} { + set requested_seps [tcl::dict::get $o_opts_table -show_seps] + set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] + set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] + set seps $requested_seps + set seps_h $requested_seps_h + set seps_v $requested_seps_v + if {$requested_seps eq ""} { + if {$requested_seps_h eq ""} { + set seps_h 1 + } + if {$requested_seps_v eq ""} { + set seps_v 1 + } + } else { + if {$requested_seps_h eq ""} { + set seps_h $seps + } + if {$requested_seps_v eq ""} { + set seps_v $seps + } + } + return [tcl::dict::create horizontal $seps_h vertical $seps_v] + } + method Get_frametypes {} { + set requested_ft [tcl::dict::get $o_opts_table -frametype] + set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] + set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] + set ft $requested_ft + set ft_header $requested_ft_header + set ft_body $requested_ft_body + switch -- $requested_ft { + light { + if {$requested_ft_header eq ""} { + set ft_header heavy + } + if {$requested_ft_body eq ""} { + 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 + } + if {$requested_ft_body eq ""} { + set ft_body $requested_ft + } + } + } + return [tcl::dict::create header $ft_header body $ft_body] + } + method Set_effective_framelimits {} { + upvar ::textblock::class::opts_table_defaults tdefaults + set default_blims [tcl::dict::get $tdefaults -framelimits_body] + set default_hlims [tcl::dict::get $tdefaults -framelimits_header] + set eff_blims [tcl::dict::get $o_opts_table_effective -framelimits_body] + set eff_hlims [tcl::dict::get $o_opts_table_effective -framelimits_header] + + set requested_blims [tcl::dict::get $o_opts_table -framelimits_body] + set requested_hlims [tcl::dict::get $o_opts_table -framelimits_header] + set blims $eff_blims + set hlims $eff_hlims + switch -- $requested_blims { + "default" { + set blims $default_blims + } + default { + #set blims $requested_blims + set blims [list] + foreach lim $requested_blims { + switch -- $lim { + hl { + lappend blims hlt hlb + } + vl { + lappend blims vll vlr + } + default { + lappend blims $lim + } + } + } + set blims [lsort -unique $blims] + } + } + tcl::dict::set o_opts_table_effective -framelimits_body $blims + switch -- $requested_hlims { + "default" { + set hlims $default_hlims + } + default { + #set hlims $requested_hlims + set hlims [list] + foreach lim $requested_hlims { + switch -- $lim { + hl { + lappend hlims hlt hlb + } + vl { + lappend hlims vll vlr + } + default { + lappend hlims $lim + } + } + } + set hlims [lsort -unique $hlims] + } + } + tcl::dict::set o_opts_table_effective -framelimits_header $hlims + 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 + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [list %topt_keys%]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_opts_table $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { + tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "[tcl::namespace::current]::table configure - unexpected argument count. Require name value pairs" + } + foreach {k v} $args { + switch -- $k { + %topt_switchkeys% {} + default { + error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + #if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { + # error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + #} + } + set checked_opts [list] + foreach {k v} $args { + switch -- $k { + -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set ansi_codes [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend ansi_codes $code + } + } + set ansival [punk::ansi::codetype::sgr_merge_singles $ansi_codes] + lappend checked_opts $k $ansival + } + -frametype - -frametype_header - -frametype_body { + #frametype will raise an error if v is not a valid custom dict or one of the known predefined types such as light,heavy,double etc + lassign [textblock::frametype $v] _cat category _type ftype + lappend checked_opts $k $v + } + -framemap_body - -framemap_header { + #upvar ::textblock::class::opts_table_defaults tdefaults + #set default_bmap [tcl::dict::get $tdefaults -framemap_body] + #todo - check keys and map + if {[llength $v] == 1} { + if {$v eq "default"} { + upvar ::textblock::class::opts_table_defaults tdefaults + set default_map [tcl::dict::get $tdefaults $k] + lappend checked_opts $k $default_map + } else { + error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}" + } + } else { + #safe jumptable test + #dict for {subk subv} $v {} + foreach {subk subv} $v { + switch -- $subk { + topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} + default { + error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" + } + } + #safe jumptable test + #dict for {seg subst} $subv {} + foreach {seg subst} $subv { + switch -- $seg { + hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {} + default { + error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}" + } + } + } + + } + lappend checked_opts $k $v + } + + } + -framelimits_body - -framelimits_header { + set specific_framelimits [list] + foreach fl $v { + switch -- $fl { + "default" { + lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr + } + hl { + lappend specific_framelimits hlt hlb + } + vl { + lappend specific_framelimits vll vlr + } + hlt - hlb - vll - vlr - trc - tlc - blc - brc { + lappend specific_framelimits $fl + } + default { + error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)" + } + } + } + lappend checked_opts $k $specific_framelimits + } + -ansireset { + if {$v eq "\uFFEF"} { + set RST "\x1b\[m" ;#[a] + lappend checked_opts $k $RST + } else { + error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -show_hseps { + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + lappend checked_opts $k $v + #these don't affect column width calculations + } + -show_edge { + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + lappend checked_opts $k $v + #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + } + -show_vseps { + #we allow empty string - so don't use -strict boolean check + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + #affects width calculations + set o_calculated_column_widths [list] + lappend checked_opts $k $v + } + -minwidth - -maxwidth { + set o_calculated_column_widths [list] + lappend checked_opts $k $v + } + default { + lappend checked_opts $k $v + } + } + } + #all options checked - ok to update o_opts_table and o_opts_table_effective + + #set o_opts_table [tcl::dict::merge $o_opts_table $checked_opts] + foreach {k v} $args { + switch -- $k { + -framemap_header - -framemap_body { + #framemaps don't require setting every key to update. + #e.g configure -framemaps {topleft } + #needs to merge with existing unspecified keys such as topright middleleft etc. + if {$v eq "default"} { + tcl::dict::set o_opts_table $k default + } else { + if {[tcl::dict::get $o_opts_table $k] eq "default"} { + tcl::dict::set o_opts_table $k $v + } else { + tcl::dict::set o_opts_table $k [tcl::dict::merge [tcl::dict::get $o_opts_table $k] $v] + } + } + } + -title { + set twidth [punk::ansi::printing_length $v] + if {[my width] < [expr {$twidth+2}]} { + set o_calculated_column_widths [list] + tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] + } + tcl::dict::set o_opts_table -title $v + } + default { + tcl::dict::set o_opts_table $k $v + } + } + } + #use values from checked_opts for the effective opts + #safe jumptable test + #dict for {k v} $checked_opts {} + #foreach {k v} $checked_opts {} + tcl::dict::for {k v} $checked_opts { + switch -- $k { + -framemap_body - -framemap_header { + set existing [tcl::dict::get $o_opts_table_effective $k] + #set updated $existing + #dict for {subk subv} $v { + # tcl::dict::set updated $subk $subv + #} + #tcl::dict::set o_opts_table_effective $k $updated + tcl::dict::set o_opts_table_effective $k [tcl::dict::merge $existing $v] + } + -framelimits_body - -framelimits_header { + #my Set_effective_framelimits + tcl::dict::set o_opts_table_effective $k $v + } + default { + tcl::dict::set o_opts_table_effective $k $v + } + } + } + #ansireset exception + tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] + return $o_opts_table + } + + #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] + if {$table_colcount == 0} { + for {set c 0} {$c < $matrix_colcount} {incr c} { + my add_column -headers "" + } + } + set table_colcount [my column_count] + if {$table_colcount != $matrix_colcount} { + error "textblock::table::printmatrix column count of table doesn't match column count of matrix" + } + if {[my row_count] > 0} { + my row_clear + } + for {set r 0} {$r < $matrix_rowcount} {incr r} { + my add_row [$matrix get row $r] + } + 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 { + set m [struct::matrix $cmd] + } + $m add columns [tcl::dict::size $o_columndata] + $m add rows [tcl::dict::size $o_rowdefs] + tcl::dict::for {k v} $o_columndata { + $m set column $k $v + } + return $m + } + method add_column {args} { + #*** !doctools + #[call class::table [method add_column] [arg args]] + + + if {[llength $args] %2 != 0} { + error "[tcl::namespace::current]::table::add_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" + } + set opts $o_opts_column_defaults + foreach {k v} $args { + switch -- $k { + %copt_switchkeys% { + tcl::dict::set opts $k $v + } + default { + error "[tcl::namespace::current]::table::add_column unknown option '$k'. Known options: %copt_keys%" + } + } + } + set colcount [tcl::dict::size $o_columndefs] + + + tcl::dict::set o_columndata $colcount [list] + #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists + tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists + + + tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] + set prev_calculated_column_widths $o_calculated_column_widths + if {[catch { + my configure_column $colcount {*}$opts + } errMsg]} { + #configure failed - ensure o_columndata and o_columndefs entries are removed + tcl::dict::unset o_columndata $colcount + tcl::dict::unset o_columndefs $colcount + tcl::dict::unset o_columnstates $colcount + #undo cache invalidation + set o_calculated_column_widths $prev_calculated_column_widths + error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" + } + #any add_column that succeeds should invalidate the calculated column widths + set o_calculated_column_widths [list] + set numrows [my row_count] + if {$numrows > 0} { + #fill column with default values + #puts ">>> adding default values for column $colcount" + set dval [tcl::dict::get $opts -defaultvalue] + set width [textblock::width $dval] + tcl::dict::set o_columndata $colcount [lrepeat $numrows $dval] + tcl::dict::set o_columnstates $colcount maxwidthbodyseen $width + tcl::dict::set o_columnstates $colcount minwidthbodyseen $width + } + 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" + } + if {![llength $args]} { + return [tcl::dict::get $o_columndefs $cidx] + } else { + if {[llength $args] == 1} { + if {[lindex $args 0] in [list %copt_keys%]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_columndefs $cidx $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + } else { + error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values %copt_keys%" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" + } + foreach {k v} $args { + switch -- $k { + %copt_switchkeys% {} + default { + error "[tcl::namespace::current]::table configure_column unknown option '$k'. Known options: %copt_keys%" + } + } + } + set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state + + set hstates $o_headerstates ;#operate on a copy + set colstate [tcl::dict::get $o_columnstates $cidx] + set args_got_headers 0 + set args_got_header_colspans 0 + foreach {k v} $args { + switch -- $k { + -headers { + set args_got_headers 1 + set i 0 + set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. + foreach hdr $v { + set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns + #set this_header_height [textblock::height $hdr] + lassign [textblock::size $hdr] _w this_header_width _h this_header_height + + if {$this_header_height >= $currentmax} { + tcl::dict::set hstates $i maxheightseen $this_header_height + } else { + tcl::dict::set hstates $i maxheightseen $currentmax + } + if {$this_header_width >= $maxseen} { + set maxseen $this_header_width + } + #if {$this_header_width > [tcl::dict::get $colstate maxwidthheaderseen]} { + # tcl::dict::set colstate maxwidthheaderseen $this_header_width + #} + incr i + } + tcl::dict::set colstate maxwidthheaderseen $maxseen + #review - we could avoid some recalcs if we check current width range compared to previous + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -header_colspans { + set args_got_header_colspans 1 + #check columns to left to make sure each new colspan for this column makes sense in the overall context + #user may have to adjust colspans in order left to right to avoid these check errors + #note that 'any' represents span all up to the next non-zero defined colspan. + set cspans [my header_colspans] + set h 0 + if {[llength $v] > [tcl::dict::size $cspans]} { + error "configure_column $cidx -header_colspans. Only [tcl::dict::size $cspans] headers exist. Too many values supplied" + } + foreach s $v { + if {$cidx == 0} { + if {[tcl::string::is integer -strict $s]} { + if {$s < 1} { + error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'any' or a positive integer" + } + } else { + if {$s ne "any" && $s ne ""} { + error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" + } + } + } else { + #if {![tcl::string::is integer -strict $s]} { + # if {$s ne "any" && $s ne ""} { + # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" + # } + #} else { + set header_spans [tcl::dict::get $cspans $h] + set remaining [lindex $header_spans 0] + if {$remaining ne "any"} { + incr remaining -1 + } + #look at spans defined for previous cols + #we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption + for {set c 0} {$c < $cidx} {incr c} { + set span [lindex $header_spans $c] + if {$span eq "any"} { + set remaining "any" + } else { + if {$remaining eq "any"} { + if {$span ne "0"} { + #a previous column has ended the 'any' span + set remaining [expr {$span -1}] + } + } else { + if {$span eq "0"} { + incr remaining -1 + } else { + set remaining [expr {$span -1}] + } + #allow to go negative + } + } + } + if {$remaining eq "any"} { + #any int >0 ok - what about 'any' immediately following any? + } else { + if {$remaining > 0} { + if {$s ne "0" && $s ne ""} { + error "configure_column $cidx -header_colspans bad span $s for header '$h'. Remaining span is '$remaining' - so a zero colspan is required" + } + } else { + if {$s == 0} { + error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" + } + } + } + #} + } + incr h + } + #todo - avoid recalc if no change + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -minwidth { + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -maxwidth { + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set col_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend col_ansibase_items $code + } + } + set col_ansibase [punk::ansi::codetype::sgr_merge_singles $col_ansibase_items] + tcl::dict::set checked_opts $k $col_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + tcl::dict::set checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -blockalign - -textalign { + switch -- $v { + left - right { + tcl::dict::set checked_opts $k $v + } + centre - centre { + tcl::dict::set checked_opts $k centre + } + } + } + default { + tcl::dict::set checked_opts $k $v + } + } + } + #args checked - ok to update headerstates, headerdefs and columndefs and columnstates + tcl::dict::set o_columndefs $cidx $checked_opts + set o_headerstates $hstates + dict for {hidx hstate} $hstates { + #configure_header + if {![dict exists $o_headerdefs $hidx]} { + #remove calculated members -values -colspans + set hdefaults [dict remove $o_opts_header_defaults -values -colspans] + dict set o_headerdefs $hidx $hdefaults + } + } + + tcl::dict::set o_columnstates $cidx $colstate + + if {$args_got_headers} { + #if the headerlist length for this column has shrunk,and it was the longest - we may now have excess entries in o_headerstates + set zero_heights [list] + tcl::dict::for {hidx _v} $o_headerstates { + #pass empty string for exclude_column so we don't exclude our own column + if {[my header_height_calc $hidx ""] == 0} { + lappend zero_heights $hidx + } + } + foreach zidx $zero_heights { + tcl::dict::unset o_headerstates $zidx + } + } + if {$args_got_headers || $args_got_header_colspans} { + #check and adjust header_colspans for all columns + + } + + return [tcl::dict::get $o_columndefs $cidx] + } + } + + 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 {} { + set max_headers 0 + tcl::dict::for {k cdef} $o_columndefs { + set num_headers [llength [tcl::dict::get $cdef -headers]] + set max_headers [expr {max($max_headers,$num_headers)}] + } + 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] + } + + #review - use maxwidth (considering colspans) of each column to determine height after wrapping + # -need to consider whether vertical expansion allowed / maxheight? + method header_height_calc {header_index {exclude_column ""}} { + set dataheight 0 + if {$exclude_column eq ""} { + set exclude_colidx "" + } else { + set exclude_colidx [lindex [tcl::dict::keys $o_columndefs] $exclude_column] + } + tcl::dict::for {cidx cdef} $o_columndefs { + if {$exclude_colidx == $cidx} { + continue + } + set headerlist [tcl::dict::get $cdef -headers] + if {$header_index < [llength $headerlist]} { + set this_height [textblock::height [lindex $headerlist $header_index]] + set dataheight [expr {max($dataheight,$this_height)}] + } + } + return $dataheight + } + + #return a dict keyed on header index with values representing colspans + #e.g + # 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] + tcl::dict::for {cidx cdef} $o_columndefs { + set headerlist [tcl::dict::get $cdef -headers] + set colspans_for_column [tcl::dict::get $cdef -header_colspans] + for {set h 0} {$h < $num_headers} {incr h} { + set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] + set defined_span [lindex $colspans_for_column $h] + set i 0 + set spanremaining [lindex $headerspans 0] + if {$spanremaining ne "any"} { + if {$spanremaining eq ""} { + set spanremaining 1 + } + incr spanremaining -1 + } + foreach s $headerspans { + if {$s eq "any"} { + set spanremaining "any" + } elseif {$s == 0} { + if {$spanremaining ne "any"} { + incr spanremaining -1 + } + } else { + set spanremaining [expr {$s - 1}] + } + incr i + } + if {$defined_span eq ""} { + if {$spanremaining eq "0"} { + lappend headerspans 1 + } else { + #"any" or an integer + lappend headerspans 0 + } + } else { + lappend headerspans $defined_span + } + tcl::dict::set colspans_by_header $h $headerspans + } + } + return $colspans_by_header + } + + #e.g + # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 any 1} 3 {any 0 0 1} + #convert to + # 0 {4 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} + method header_colspans_numeric {} { + set hcolspans [my header_colspans] + if {![tcl::dict::size $hcolspans]} { + return + } + set numcols [llength [tcl::dict::get $hcolspans 0]] ;#assert: all are the same + tcl::dict::for {h spans} $hcolspans { + set c 0 ;#column index + foreach s $spans { + if {$s eq "any"} { + set spanlen 1 + for {set i [expr {$c+1}]} {$i < $numcols} {incr i} { + #next 'any' or non-zero ends an 'any' span + if {[lindex $spans $i] ne "0"} { + break + } + incr spanlen + } + #overwrite the 'any' with it's actual span + set modified_spans [dict get $hcolspans $h] + lset modified_spans $c $spanlen + dict set hcolspans $h $modified_spans + } + incr c + } + } + return $hcolspans + } + + method configure_header {index_expression args} { + #*** !doctools + #[call class::table [method configure_header]] + #[para] - configure header row-wise + + #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} + set num_headers [my header_count_calc] + set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression] + if {$hidx eq ""} { + error "textblock::table::configure_header - no header row defined at index '$index_expression'." + } + if {$hidx > $num_headers -1} { + #assert - shouldn't happen + error "textblock::table::configure_header error headerstates data is out of sync" + } + + if {![llength $args]} { + set colspans_by_header [my header_colspans] + set result [tcl::dict::create] + tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] + set header_row_items [list] + tcl::dict::for {cidx cdef} $o_columndefs { + set colheaders [tcl::dict::get $cdef -headers] + set relevant_header [lindex $colheaders $hidx] + #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + } + tcl::dict::set result -values $header_row_items + + #review - ensure always a headerdef record for each header? + if {[tcl::dict::exists $o_headerdefs $hidx]} { + set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]] + } else { + #warn for now + puts stderr "no headerdef record for header $hidx" + } + return $result + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [tcl::dict::keys $o_opts_header_defaults]} { + #query single option + set k [lindex $args 0] + #set val [tcl::dict::get $o_rowdefs $ridx $k] + + set infodict [tcl::dict::create] + #todo + # -blockalignments and -textalignments lists + # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} + #if there is a value it overrides alignments specified on the column + switch -- $k { + -values { + set header_row_items [list] + tcl::dict::for {cidx cdef} $o_columndefs { + set colheaders [tcl::dict::get $cdef -headers] + set relevant_header [lindex $colheaders $hidx] + #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + + } + set val $header_row_items + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + } + -colspans { + set colspans_by_header [my header_colspans] + set result [tcl::dict::create] + set val [tcl::dict::get $colspans_by_header $hidx] + #ansireset not required + set returndict [tcl::dict::create option $k value $val] + } + -ansibase { + set val ??? + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_header_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_header_defaults]" + } + foreach {k v} $args { + if {$k ni [tcl::dict::keys $o_opts_header_defaults]} { + error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_header_defaults]" + } + } + + set checked_opts [list] + #safe jumptable test + #dict for {k v} $args {} + foreach {k v} $args { + switch -- $k { + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set header_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend header_ansibase_items $code + } + } + set header_ansibase [punk::ansi::codetype::sgr_merge_singles $header_ansibase_items] + lappend checked_opts $k $header_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + lappend checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -values { + if {[llength $v] > [tcl::dict::size $o_columndefs]} { + error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" + } + lappend checked_opts $k $v + } + -colspans { + set numcols [tcl::dict::size $o_columndefs] + if {[llength $v] > $numcols} { + error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" + } + if {[llength $v] < $numcols} { + puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." + puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" + } + if {[llength $v]} { + set firstspan [lindex $v 0] + set first_is_ok 0 + if {$firstspan eq "any"} { + set first_is_ok 1 + } elseif {[tcl::string::is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} { + set first_is_ok 1 + } + if {!$first_is_ok} { + error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" + } + #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) + set remaining $firstspan + if {$remaining ne "any"} { + incr remaining -1 + } + set spanview $v + set sidx 1 + #because we allow 'any' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'any' first + foreach span [lrange $v 1 end] { + if {$remaining eq "any"} { + if {$span eq "any"} { + set remaining "any" + } elseif {$span > 0} { + #ok to reset to higher val immediately or after an any and any number of following zeros + if {$span > ($numcols - $sidx)} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" + } + set remaining $span + incr remaining -1 + } else { + #zero following an any - leave remaining as any + } + } else { + if {$span eq "0"} { + if {$remaining eq "0"} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" + } else { + incr remaining -1 + } + } else { + if {$remaining eq "0"} { + #ok for new span value of any or > 0 + if {$span ne "any" && $span > ($numcols - $sidx)} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" + } + set remaining $span + if {$remaining ne "any"} { + incr remaining -1 + } + } else { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" + } + } + } + incr sidx + } + } + #empty -colspans list should be ok + + #error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now" + lappend checked_opts $k $v + } + default { + lappend checked_opts $k $v + } + } + } + + #configured opts all good + #safe jumptable test + #dict for {k v} $checked_opts {} + #foreach {k v} $checked_opts {} + + # headerdefs excludes -values and -colspans + set update_hdefs [tcl::dict::get $o_headerdefs $hidx] + + tcl::dict::for {k v} $checked_opts { + switch -- $k { + -values { + set c 0 + foreach hval $v { + #retrieve -headers from relevant col, insert at header index, and write back. + set thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers] + set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}] + if {$missing > 0} { + lappend thiscol_headers_vertical {*}[lrepeat $missing ""] + } + lset thiscol_headers_vertical $hidx $hval + tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical + #invalidate column width cache + set o_calculated_column_widths [list] + # -- -- -- -- -- -- + #also update maxwidthseen & maxheightseen + set i 0 + set maxwidthseen 0 + #set maxheightseen 0 + foreach hdr $thiscol_headers_vertical { + lassign [textblock::size $hdr] _w this_header_width _h this_header_height + set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0] + if {$this_header_height >= $maxheightseen} { + tcl::dict::set o_headerstates $i maxheightseen $this_header_height + } else { + tcl::dict::set o_headerstates $i maxheightseen $maxheightseen + } + if {$this_header_width >= $maxwidthseen} { + set maxwidthseen $this_header_width + } + incr i + } + tcl::dict::set o_columnstates $c maxwidthheaderseen $maxwidthseen + # -- -- -- -- -- -- + incr c + } + } + -colspans { + #sequence has been verified above - we need to split it and store across columns + set c 0 ;#column index + foreach span $v { + set colspans [tcl::dict::get $o_columndefs $c -header_colspans] + if {$hidx > [llength $colspans]-1} { + set colspans_by_header [my header_colspans] + #puts ">>>>>?$colspans_by_header" + #we are allowed to lset only one beyond the current length to append + #but there may be even less or no entries present in a column + # - the ability to underspecify and calculate the missing values makes setting the values complicated. + #use the header_colspans calculation to update only those entries necessary + set spanlist [list] + for {set h 0} {$h < $hidx} {incr h} { + set cspans [tcl::dict::get $colspans_by_header $h] + set requiredval [lindex $cspans $c] + lappend spanlist $requiredval + } + tcl::dict::set o_columndefs $c -header_colspans $spanlist + + set colspans [tcl::dict::get $o_columndefs $c -header_colspans] + } + + lset colspans $hidx $span + tcl::dict::set o_columndefs $c -header_colspans $colspans + incr c + } + } + default { + dict set update_hdefs $k $v + } + } + } + set opt_minh [tcl::dict::get $update_hdefs -minheight] + set opt_maxh [tcl::dict::get $update_hdefs -maxheight] + + #todo - allow zero values to hide/collapse + # - see also configure_row + if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { + error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" + } + if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { + error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" + } + if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { + error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" + } + + #set o_headerstate $hidx -minheight? -maxheight? ??? + tcl::dict::set o_headerdefs $hidx $update_hdefs + } + + method add_row {valuelist args} { + #*** !doctools + #[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 + append msg "rowdata: $valuelist" + error $msg + } + if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { + error "add_row - no values supplied, and no columns defined, so cannot use default column values" + } + + set defaults [tcl::dict::create\ + -minheight 1\ + -maxheight ""\ + -ansibase ""\ + -ansireset "\uFFEF"\ + ] + set o_opts_row_defaults $defaults + + if {[llength $args] %2 !=0} { + error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" + } + #safe jumptable test + #dict for {k v} $args {} + foreach {k v} $args { + switch -- $k { + -minheight - -maxheight - -ansibase - -ansireset {} + default { + error "Invalid option '$k' Known options: [tcl::dict::keys $defaults] (-ansireset is read-only)" + } + } + } + set opts [tcl::dict::merge $defaults $args] + + set auto_columns 0 + if {[tcl::dict::size $o_columndefs] == 0} { + set auto_columns 1 + #no columns defined - auto define with defaults for each column in first supplied row + #auto define columns only valid if no existing columns + #the autocolumns must be added before configure_row - but if configure_row fails - we need to remove them! + foreach el $valuelist { + my add_column + } + } else { + if {![llength $valuelist]} { + tcl::dict::for {k coldef} $o_columndefs { + lappend valuelist [tcl::dict::get $coldef -defaultvalue] + } + } + } + set rowcount [tcl::dict::size $o_rowdefs] + tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure + + if {[catch { + my configure_row $rowcount {*}$opts + } errMsg]} { + #undo anything we saved before configure_row + tcl::dict::unset o_rowdefs $rowcount + #remove auto_columns + if {$auto_columns} { + set o_columndata [tcl::dict::create] + set o_columndefs [tcl::dict::create] + set o_columnstate [tcl::dict::create] + } + error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" + } + + + set c 0 + set max_height_seen 1 + foreach v $valuelist { + set prev_maxwidth [tcl::dict::get $o_columnstates $c maxwidthbodyseen] + set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] + + tcl::dict::lappend o_columndata $c $v + lassign [textblock::size_as_list $v] valwidth valheight + if {$valheight > $max_height_seen} { + set max_height_seen $valheight + } + if {$valwidth > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { + tcl::dict::set o_columnstates $c maxwidthbodyseen $valwidth + } + 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} { + #invalidate calculated column width cache if any new value was outside the previous range of widths + set o_calculated_column_widths [list] + } + incr c + } + + set opt_maxh [tcl::dict::get $o_rowdefs $rowcount -maxheight] + if {$opt_maxh ne ""} { + tcl::dict::set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}] + } else { + tcl::dict::set o_rowstates $rowcount -maxheight $max_height_seen + } + + 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" + } + if {![llength $args]} { + return [tcl::dict::get $o_rowdefs $ridx] + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [tcl::dict::keys $o_opts_row_defaults]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_rowdefs $ridx $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_row_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_row_defaults]" + } + foreach {k v} $args { + if {$k ni [tcl::dict::keys $o_opts_row_defaults]} { + error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_row_defaults]" + } + } + set checked_opts [list] + foreach {k v} $args { + switch -- $k { + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set row_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend row_ansibase_items $code + } + } + set row_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] + lappend checked_opts $k $row_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + lappend checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_row -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + default { + lappend checked_opts $k $v + } + } + } + + set current_opts [tcl::dict::get $o_rowdefs $ridx] + set opts [tcl::dict::merge $current_opts $checked_opts] + + #check minheight and maxheight together + set opt_minh [tcl::dict::get $opts -minheight] + set opt_maxh [tcl::dict::get $opts -maxheight] + + #todo - allow zero values to hide/collapse rows as is possible with columns + if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { + error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" + } + if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { + error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" + } + if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { + error "[tcl::namespace::current]::table::configure_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" + } + tcl::dict::set o_rowstates $ridx -minheight $opt_minh + + + 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 + tcl::dict::for {cidx records} $o_columndata { + tcl::dict::set o_columndata $cidx [list] + #reset only the body fields in o_columnstates + tcl::dict::set o_columnstates $cidx minwidthbodyseen 0 + tcl::dict::set o_columnstates $cidx maxwidthbodyseen 0 + } + 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] + set o_columnstates [tcl::dict::create] + } + + + + #method Get_columns_by_name {namematch_list} { + #} + + #specify range with x..y + method Get_columns_by_indices {index_list} { + foreach spec $index_list { + if {[tcl::string::is integer -strict $c]} { + set colidx $c + } else { + tcl::dict::for {colidx coldef} $o_columndefs { + #if {[tcl::string::match x x]} {} + } + } + } + } + method Get_boxlimits_and_joins {position fname_body} { + #fname_body will be "custom" or one of the predefined types light,heavy etc + switch -- $position { + left { + return [tcl::dict::create \ + boxlimits [list hlb blc vll]\ + boxlimits_top [list hlb blc vll hlt tlc]\ + joins [list down]\ + bodyjoins [list down-$fname_body]\ + ] + } + inner { + return [tcl::dict::create \ + boxlimits [list hlb blc vll]\ + boxlimits_top [list hlb blc vll hlt tlc]\ + joins [list down left]\ + bodyjoins [list left down-$fname_body] + ] + } + right { + return [tcl::dict::create \ + boxlimits [list hlb blc vll vlr brc]\ + boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ + joins [list down left]\ + bodyjoins [list left down-$fname_body]\ + ] + } + solo { + return [tcl::dict::create \ + boxlimits [list hlb blc vll vlr brc]\ + boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ + joins [list down]\ + bodyjoins [list down-$fname_body]\ + ] + } + default { + error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo" + } + } + } + method Get_boxlimits_and_joins1 {position fname_body} { + #fname_body will be "custom" or one of the predefined types light,heavy etc + switch -- $position { + left { + #set header_boxlimits {hlb hlt tlc blc vll} + set header_body_joins [list down-$fname_body] + set boxlimits_position [list hlb blc vll] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] + set boxlimits_toprow [list hlb blc vll hlt tlc] + set joins [list down] + } + inner { + #set header_boxlimits {hlb hlt tlc blc vll} + set header_body_joins [list left down-$fname_body] + set boxlimits_position [list hlb blc vll] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] + set boxlimits_toprow [list hlb blc vll hlt tlc] + set joins [list down left] + } + right { + #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} + set header_body_joins [list left down-$fname_body] + set boxlimits_position [list hlb blc vll vlr brc] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] + set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] + set joins [list down left] + } + solo { + #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} + set header_body_joins [list down-$fname_body] + set boxlimits_position [list hlb blc vll vlr brc] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] + set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] + set joins [list down] + } + } + return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ] + } + method get_column_by_index {index_expression args} { + #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" + #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. + set opts [tcl::dict::create\ + -position "inner"\ + -return "string"\ + ] + foreach {k v} $args { + switch -- $k { + -position - -return { + tcl::dict::set opts $k $v + } + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid option '$k'. Known options [tcl::dict::keys $opts]" + } + } + } + set opt_posn [tcl::dict::get $opts -position] + set opt_return [tcl::dict::get $opts -return] + + switch -- $opt_posn { + left - inner - right - solo {} + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo]" + } + } + switch -- $opt_return { + string - dict {} + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_return' for -return. Valid values: string dict" + } + } + + set columninfo [my get_column_cells_by_index $index_expression] + set header_list [tcl::dict::get $columninfo headers] + #puts "===== header_list: $header_list" + set cells [tcl::dict::get $columninfo cells] + + set topt_show_header [tcl::dict::get $o_opts_table -show_header] + if {$topt_show_header eq ""} { + set allheaders 0 + set all_cols [tcl::dict::keys $o_columndefs] + foreach c $all_cols { + incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] + } + if {$allheaders == 0} { + set do_show_header 0 + } else { + set do_show_header 1 + } + } else { + set do_show_header $topt_show_header + } + set topt_show_footer [tcl::dict::get $o_opts_table -show_footer] + + + set output "" + set part_header "" + set part_body "" + set part_footer "" + + set boxlimits "" + set joins "" + set header_boxlimits [list] + set header_body_joins [list] + + + set ftypes [my Get_frametypes] + set ftype_body [tcl::dict::get $ftypes body] + if {[llength $ftype_body] >= 2} { + set fname_body "custom" + } else { + set fname_body $ftype_body + } + set ftype_header [tcl::dict::get $ftypes header] + if {[llength $ftype_header] >= 2} { + set fname_header "custom" + } else { + set fname_header $ftype_header + } + + set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] + set header_body_joins [tcl::dict::get $limj bodyjoins] + set joins [tcl::dict::get $limj joins] + set boxlimits_position [tcl::dict::get $limj boxlimits] + set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] + #use struct::set instead of simple for loop - will be faster at least when critcl available + set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] + set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] + set header_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_position] + set header_boxlimits_toprow [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_toprow] + + set fmap [tcl::dict::get $o_opts_table_effective -framemap_body] + set hmap [tcl::dict::get $o_opts_table_effective -framemap_header] + + #if {![tcl::dict::get $o_opts_table -show_edge]} { + # set body_edgemap [textblock::class::table_edge_map ""] + # dict for {k v} $fmap { + # #tcl::dict::set fmap $k [tcl::dict::merge $v [tcl::dict::get $body_edgemap $k]] + # } + # set header_edgemap [textblock::class::header_edge_map ""] + # dict for {k v} $hmap { + # #tcl::dict::set hmap $k [tcl::dict::merge $v [tcl::dict::get $header_edgemap $k]] + # } + #} + set sep_elements_horizontal $::textblock::class::table_hseps + set sep_elements_vertical $::textblock::class::table_vseps + + set topmap [tcl::dict::get $fmap top$opt_posn] + set botmap [tcl::dict::get $fmap bottom$opt_posn] + set midmap [tcl::dict::get $fmap middle$opt_posn] + set onlymap [tcl::dict::get $fmap only$opt_posn] + + set hdrmap [tcl::dict::get $hmap only${opt_posn}] + + set topseps_h [tcl::dict::get $sep_elements_horizontal top$opt_posn] + set midseps_h [tcl::dict::get $sep_elements_horizontal middle$opt_posn] + set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] + set midseps_v [tcl::dict::get $sep_elements_vertical middle$opt_posn] + set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] + set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] + + #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway + set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] + + lassign [my Get_seps] _h show_seps_h _v show_seps_v + set return_headerheight 0 + set return_headerwidth 0 + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + + set colwidth [my column_width $cidx] + + set col_blockalign [tcl::dict::get $o_columndefs $cidx -blockalign] + + if {$do_show_header} { + #puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap" + set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure + set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] + if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { + set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] + set ansiborder_final $ansibase_header$ansiborder_header$extrabg + } else { + set ansiborder_final $ansibase_header$ansiborder_header + } + set RST [punk::ansi::a] + + + set hcolwidth $colwidth + #set hcolwidth [my column_width_configured $cidx] + set hcell_line_blank [tcl::string::repeat " " $hcolwidth] + + set all_colspans [my header_colspans_numeric] + + #put our framedef calls together + set fdef_header [textblock::framedef $ftype_header] + set framedef_leftbox [textblock::framedef -joins left $ftype_header] + set framedef_headerdown_same [textblock::framedef -joins {down} $ftype_header] + set framedef_headerdown_body [textblock::framedef -joins [list down-$fname_body] $ftype_header] + #default span_extend_map - used as base to customise with specific joins + set span_extend_map [tcl::dict::create \ + vll " "\ + tlc [tcl::dict::get $fdef_header hlt]\ + blc [tcl::dict::get $fdef_header hlb]\ + ] + + + #used for colspan-zero header frames + set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test + + set hrow 0 + set hmax [expr {[llength $header_list] -1}] + foreach header $header_list { + set headerspans [tcl::dict::get $all_colspans $hrow] + set this_span [lindex $headerspans $cidx] + #set hval $ansibase_header$header ;#no reset + set hval $header + set rowh [my header_height $hrow] + + if {$hrow == 0} { + set hlims $header_boxlimits_toprow + set rowpos "top" + if {$hrow == $hmax} { + set rowpos "only" + } + } else { + set hlims $header_boxlimits + set rowpos "middle" + if {$hrow == $hmax} { + set rowpos "bottom" + } + } + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {$hrow == $hmax} { + set header_joins $header_body_joins + } else { + set header_joins $joins + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + } + #puts ">>> headerspans: $headerspans cidx: $cidx" + + #if {$this_span eq "any" || $this_span > 0} {} + #changed to processing only numeric colspans + + if {$this_span > 0} { + set startmap [tcl::dict::get $hmap $rowpos${opt_posn}] + #look at spans in header below to determine joins required at blc + if {$show_seps_v} { + if {[tcl::dict::exists $all_colspans [expr {$hrow+1}]]} { + set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] + set spanbelow [lindex $next_spanlist $cidx] + if {$spanbelow == 0} { + #we don't want a down-join for blc - use a framedef with only left joins + tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] + } + } else { + set next_spanlist [list] + } + } + + #supporting wrapping in headers might be a step too difficult for little payoff. + #we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib) + #The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex. + #May be better to require user to pre-wrap as needed + ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] + + #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used + #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) + + # -width is always +2 - as the boxlimits take into account show_vseps and show_edge + #set header_cell_startspan [textblock::frame -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 $hval\ + # ] + + if {$this_span == 1} { + #write the actual value now + set cellcontents $hval + } else { + #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 -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\ + ] + + if {$this_span != 1} { + #puts "===>\n$header_cell_startspan\n<===" + set spanned_parts [list $header_cell_startspan] + #assert this_span == "any" or >1 ie a header that spans other columns + #therefore more parts to append + #set remaining_cols [lrange [tcl::dict::keys $o_columndefs] $cidx end] + set remaining_spans [lrange $headerspans $cidx+1 end] + set spanval [join $remaining_spans ""] ;#so we can test for all zeros + set spans_to_rhs 0 + if {[expr {$spanval}] == 0} { + #puts stderr "SPANS TO RHS" + set spans_to_rhs 1 + } + + #puts ">> remaining_spans: $remaining_spans" + set spancol [expr {$cidx + 1}] + set h_lines [lrepeat $rowh ""] + set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + + + + set last [expr {[llength $remaining_spans] -1}] + set i 0 + foreach s $remaining_spans { + if {$s == 0} { + if {$i == $last} { + set next_posn right + #set next_posn inner + } else { + set next_posn inner + } + + set next_headerseps_v [tcl::dict::get $sep_elements_vertical top$next_posn] ;#static top ok + + set limj [my Get_boxlimits_and_joins $next_posn $fname_body] + set span_joins_body [tcl::dict::get $limj bodyjoins] + set span_joins [tcl::dict::get $limj joins] + set span_boxlimits [tcl::dict::get $limj boxlimits] + set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] + #use struct::set instead of simple for loop - will be faster at least when critcl available + #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] + #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] + set header_span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits] + set header_span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits_top] + if {$hrow == 0} { + set hlims $header_span_boxlimits_top + } else { + set hlims $header_span_boxlimits + } + + set this_span_map $span_extend_map + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $next_headerseps_v] + } else { + if {[llength $next_spanlist]} { + set spanbelow [lindex $next_spanlist $spancol] + if {$spanbelow != 0} { + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype + } + } else { + #join to body + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype + } + } + + if {$hrow == $hmax} { + set header_joins $span_joins_body + } else { + set header_joins $span_joins + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] + } + + set contentwidth [my column_width $spancol] + set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [tcl::dict::get $ftypes header]\ + -ansibase $ansibase_header -ansiborder $ansiborder_final\ + -boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\ + ] + lappend spanned_parts $header_cell + } else { + break + } + incr spancol + incr i + } + + #JMN + #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic + set spanned_frame [textblock::join_basic -- {*}$spanned_parts] + + if {$spans_to_rhs} { + if {$cidx == 0} { + set fake_posn solo + } else { + set fake_posn right + } + set x_limj [my Get_boxlimits_and_joins $fake_posn $fname_body] + if {$hrow == 0} { + set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] + } else { + set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] + } + } else { + if {$hrow == 0} { + set hlims $header_boxlimits_toprow + } else { + set hlims $header_boxlimits + } + } + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + if {$spans_to_rhs} { + #assert fake_posn has been set above based on cidx and spans_to_rhs + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts ${rowpos}$fake_posn] ] + } else { + #use the edge_parts corresponding to the column being written to ie use opt_posn + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + } + } + + set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements + #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 -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]" + #puts "==>hval:'[ansistring VIEW $hval]'" + #set spanned_frame [overtype::renderspace -transparent 1 $spanned_frame $hblock] + + #spanned values default left - todo make configurable + + #TODO + #consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span + #we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes? + #this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span. + #(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned) + + set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] + #POTENTIAL BUG (fixed with spans_to_rhs above) + #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) + #we need to shift 1 to the left when doing our overtype with blockalign right + #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge + #(even though the column position may be left or inner) + + + + } else { + #this_span == 1 + set spanned_frame [textblock::join_basic -- $header_cell_startspan] + } + + + append part_header $spanned_frame + append part_header \n + } else { + #zero span header directly in this column ie one that is being colspanned by some column to our left + #previous col will already have built lines for this in it's own header rhs overhang + #we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent. + + #set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1] + + #if there are no header elements above then we will need a minimum of the column width + #may be extended to the widest portion of the header in the loop below + set padwidth [my column_width $cidx] + + + #under assumption we are building table using L frame method and that horizontal borders are only ever 1 high + # - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc + #avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 ) + if 0 { + #breaks -show_edge 0 + if {$rowpos eq "top" && [tcl::dict::get $o_opts_table -show_edge]} { + set padheight [expr {$rowh + 2}] + } else { + set padheight [expr {$rowh + 1}] + } + set bline [tcl::string::repeat $TSUB [expr {$padwidth +1}]] + set h_lines [lrepeat $padheight $bline] + set hcell_blank [::join $h_lines \n] + set header_frame $hcell_blank + } else { + set bline [tcl::string::repeat $TSUB $padwidth] + set h_lines [lrepeat $rowh $bline] + set hcell_blank [::join $h_lines \n] + # -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 -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ + -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ + ] + } + + append part_header $header_frame\n + + } + incr hrow + } + if {![llength $header_list]} { + #no headers - but we've been asked to show_header + #display a zero content-height header (ie outline if edge is being shown - or bottom bar) + set hlims $header_boxlimits_toprow + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + 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 -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\ + ] + append part_header $header_frame\n + } + set part_header [tcl::string::trimright $part_header \n] + lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight + + set padline [tcl::string::repeat $TSUB $return_headerwidth] + set adjusted_lines [list] + foreach ln [split $part_header \n] { + if {[tcl::string::first $TSUB $ln] >=0} { + lappend adjusted_lines $padline + } else { + lappend adjusted_lines $ln + } + } + set part_header [::join $adjusted_lines \n] + #append output $part_header \n + } + + set r 0 + set rmax [expr {[llength $cells]-1}] + + + set blims_mid $boxlimits + set blims_top $boxlimits + set blims_bot $boxlimits + set blims_top_headerless $boxlimits_headerless + set blims_only $boxlimits + set blims_only_headerless $boxlimits_headerless + if {!$show_seps_h} { + set blims_mid [struct::set difference $blims_mid $midseps_h] + set blims_top [struct::set difference $blims_top $topseps_h] + set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_h] + } + if {!$show_seps_v} { + set blims_mid [struct::set difference $blims_mid $midseps_v] + set blims_top [struct::set difference $blims_top $topseps_v] + set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_v] + set blims_bot [struct::set difference $blims_bot $botseps_v] + set blims_only [struct::set difference $blims_only $onlyseps_v] + set blims_only_headerless [struct::set difference $blims_only_headerless $onlyseps_v] + } + + set colidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range + + set opt_col_ansibase [tcl::dict::get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column + #set colwidth [my column_width $colidx] + + set body_ansibase [tcl::dict::get $o_opts_table -ansibase_body] + #set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body + set body_ansiborder [tcl::dict::get $o_opts_table -ansiborder_body] + if {[tcl::dict::get $o_opts_table -frametype] eq "block"} { + #block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled + #we need to only accept background ansi codes from the columndef ansibase for this + set col_bg [punk::ansi::codetype::sgr_merge_singles [list $opt_col_ansibase] -filter_fg 1] ;#special merge for block borders - don't override fg colours + set border_ansi $body_ansibase$body_ansiborder$col_bg + } else { + set border_ansi $body_ansibase$body_ansiborder + } + + + set r 0 + set ftblock [expr {[tcl::dict::get $o_opts_table -frametype] eq "block"}] + foreach c $cells { + #cells in column - each new c is in a different row + set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] + set row_bg "" + if {$row_ansibase ne ""} { + set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] + } + + set ansibase $body_ansibase$opt_col_ansibase + #todo - joinleft,joinright,joindown based on opts in args + set cell_ansibase "" + + set ansiborder_body_col_row $border_ansi$row_bg + set ansiborder_final $ansiborder_body_col_row + #$c will always have ansi resets due to overtype behaviour ? + #todo - review overtype + if {[punk::ansi::ta::detect $c]} { + #use only the last ansi sequence in the cell value + #Filter out foreground and use background for ansiborder override + set parts [punk::ansi::ta::split_codes_single $c] + #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt + set codes [list] + foreach {pt cd} $parts { + if {$cd ne ""} { + lappend codes $cd + } + } + #set takebg [lindex $parts end-1] + #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] + set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] + #puts --->[ansistring VIEW $codes] + + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { + #special case double reset at end of content + set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters + set ansibase "" + set row_ansibase "" + if {$ftblock} { + set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1] + } + set cell_ansibase $cell_ansi_tail + } else { + #single trailing reset in content + set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase + } + } else { + if {$ftblock} { + #no resets - use cell's bg to extend to the border - only for block frames + set ansiborder_final $ansiborder_body_col_row$cell_bg + } + set cell_ansibase $cell_bg + } + } + + set ansibase_final $ansibase$row_ansibase$cell_ansibase + + if {$r == 0} { + if {$r == $rmax} { + set joins [lremove $joins [lsearch $joins down*]] + set bmap $onlymap + if {$do_show_header} { + set blims $blims_only + } else { + set blims $blims_only_headerless + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] + } + } else { + set bmap $topmap + if {$do_show_header} { + set blims $blims_top + } else { + set blims $blims_top_headerless + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] + } + } + 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 { + if {$r == $rmax} { + set joins [lremove $joins [lsearch $joins down*]] + set bmap $botmap + set blims $blims_bot + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts bottom$opt_posn] ] + } + } else { + set bmap $midmap + set blims $blims_mid ;#will only be reduced from boxlimits if -show_seps was processed above + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] + } + } + 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 + } + #return empty (zero content height) row if no rows + if {![llength $cells]} { + set joins [lremove $joins [lsearch $joins down*]] + #we need to know the width of the column to setup the empty cell properly + #even if no header displayed - we should take account of any defined column widths + set colwidth [my column_width $index_expression] + + if {$do_show_header} { + set blims $blims_only + } else { + append part_body \n + set blims $blims_only_headerless + } + #note that if show_edge is 0 - then for this empty line - we will not expect to see any bars + #This is because the frame with no data had vertical components made entirely of corner elements + #we could just append a newline when -show_edge is zero, but we want the correct width even when empty - for proper column joins when there are colspanned headers. + # + if {![tcl::dict::get $o_opts_table -show_edge]} { + #set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] + #append output [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n + append part_body [tcl::string::repeat " " $colwidth] \n + set return_bodywidth $colwidth + } else { + 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] + } + } + #assert bodywidth is integer >=0 whether there are rows or not + + #trim only 1 newline + if {[tcl::string::index $part_body end] eq "\n"} { + set part_body [tcl::string::range $part_body 0 end-1] + } + set return_bodyheight [textblock::height $part_body] + #append output $part_body + + if {$opt_return eq "string"} { + if {$part_header ne ""} { + set output $part_header + if {$part_body ne ""} { + append output \n $part_body + } + } else { + set output $part_body + } + return $output + } else { + return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] + } + } + + 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 "" + if {[tcl::dict::size $o_columndefs] > 0} { + set range "0..[expr {[tcl::dict::size $o_columndefs] -1}]" + } else { + set range empty + } + error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" + } + #assert cidx is integer >=0 + set num_header_rows [my header_count] + set cdef [tcl::dict::get $o_columndefs $cidx] + set headerlist [tcl::dict::get $cdef -headers] + set ansibase_col [tcl::dict::get $cdef -ansibase] + set textalign [tcl::dict::get $cdef -textalign] + switch -- $textalign { + left {set pad right} + right {set pad left} + default { + set pad "centre" ;#todo? + } + } + + #set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] + #set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] + + #set header_underlay $ansibase_header$cell_line_blank + + #set hdrwidth [my column_width_configured $cidx] + #set all_colspans [my header_colspans] + #we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric + set all_colspans [my header_colspans_numeric] + #JMN + #store configured widths so we don't look up for each header line + #set configured_widths [list] + #foreach c [tcl::dict::keys $o_columndefs] { + # #lappend configured_widths [my column_width $c] + # #we don't just want the width of the column in the body - or the headers will get truncated + # lappend configured_widths [my column_width_configured $c] + #} + + set output [tcl::dict::create] + tcl::dict::set output headers [list] + + set showing_vseps [my Showing_vseps] + for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} { + set hdr [lindex $headerlist $hrow] + #jjj + set header_maxdataheight [tcl::dict::get $o_headerstates $hrow maxheightseen] + #set header_maxdataheight [my header_height $hrow] ;#from cached headerstates + set headerdefminh [tcl::dict::get $o_headerdefs $hrow -minheight] + set headerdefmaxh [tcl::dict::get $o_headerdefs $hrow -maxheight] + if {"$headerdefminh$headerdefmaxh" ne "" && $headerdefminh eq $headerdefmaxh} { + set headerh $headerdefminh ;#exact height defined for the row + } else { + if {$headerdefminh eq ""} { + if {$headerdefmaxh eq ""} { + #both defs empty + set headerh $header_maxdataheight + } else { + set headerh [expr {min(1,$headerdefmaxh,$header_maxdataheight)}] + } + } else { + if {$headerdefmaxh eq ""} { + set headerh [expr {max($headerdefminh,$header_maxdataheight)}] + } else { + if {$header_maxdataheight < $headerdefminh} { + set headerh $headerdefminh + } else { + set headerh [expr {max($headerdefminh,$header_maxdataheight)}] + } + } + } + } + + + set headerrow_colspans [tcl::dict::get $all_colspans $hrow] + set this_span [lindex $headerrow_colspans $cidx] + + #set this_hdrwidth [lindex $configured_widths $cidx] + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign + + set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] + set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] + set hval_lines [split $hdr \n] + #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] + tcl::dict::lappend output headers $hcell + } + + + #set colwidth [my column_width $cidx] + #set cell_line_blank [tcl::string::repeat " " $colwidth] + set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1] + set cell_line_blank [tcl::string::repeat " " $datawidth] + + + + set items [tcl::dict::get $o_columndata $cidx] + #puts "---> columndata $o_columndata" + + #set opt_row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] + #set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase + + tcl::dict::set output cells [list];#ensure we return something for cells key if no items in list + set r 0 + foreach cval $items { + #todo move to row_height method ? + set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] + set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] + set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] + if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { + set rowh $rowdefminh ;#an exact height is defined for the row + } else { + if {$rowdefminh eq ""} { + if {$rowdefmaxh eq ""} { + #both defs empty + set rowh $maxdataheight + } else { + set rowh [expr {min(1,$rowdefmaxh,$maxdataheight)}] + } + } else { + if {$rowdefmaxh eq ""} { + set rowh [expr {max($rowdefminh,$maxdataheight)}] + } else { + if {$maxdataheight < $rowdefminh} { + set rowh $rowdefminh + } else { + set rowh [expr {max($rowdefminh,$maxdataheight)}] + } + } + } + } + + set cell_lines [lrepeat $rowh $cell_line_blank] + #set cell_blank [join $cell_lines \n] + + + set cval_lines [split $cval \n] + #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] + + #//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 + + incr r + } + 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 + } + 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\ + ] + foreach {k v} $args { + switch -- $k { + -usetables {} + default { + error "table debug unrecognised option '$k'. Known options: [tcl::dict::keys $defaults]" + } + } + } + set opts [tcl::dict::merge $defaults $args] + set opt_usetables [tcl::dict::get $opts -usetables] + + puts stdout "rowdefs: $o_rowdefs" + puts stdout "rowstates: $o_rowstates" + #puts stdout "columndefs: $o_columndefs" + puts stdout "columndefs:" + if {!$opt_usetables} { + tcl::dict::for {k v} $o_columndefs { + puts " $k $v" + } + } else { + set t [textblock::class::table new] + $t add_column -headers "Col" + tcl::dict::for {col coldef} $o_columndefs { + foreach property [tcl::dict::keys $coldef] { + if {$property eq "-ansireset"} { + continue + } + $t add_column -headers $property + } + break + } + + #build our inner tables first so we can sync widths + set col_header_tables [tcl::dict::create] + set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths + tcl::dict::for {col coldef} $o_columndefs { + set row [list $col] + set colheaders [tcl::dict::get $coldef -headers] + #inner table probably overkill here ..but just as easy + set htable [textblock::class::table new] + $htable configure -show_header 1 -show_edge 0 -show_hseps 0 + $htable add_column -headers row + $htable add_column -headers text + $htable add_column -headers WxH + $htable add_column -headers span + set hnum 0 + set spans [tcl::dict::get $o_columndefs $col -header_colspans] + foreach h $colheaders s $spans { + lassign [textblock::size $h] _w width _h height + $htable add_row [list "$hnum " $h "${width}x${height}" $s] + incr hnum + } + $htable configure_column 0 -ansibase [a+ web-dimgray] + tcl::dict::set col_header_tables $col $htable + set colwidths [$htable column_widths] + set icol 0 + foreach w $colwidths { + if {$w > [tcl::dict::get $max_widths $icol]} { + tcl::dict::set max_widths $icol $w + } + incr icol + } + } + + #safe jumptable test + #dict for {col coldef} $o_columndefs {} + tcl::dict::for {col coldef} $o_columndefs { + set row [list $col] + #safe jumptable test + #dict for {property val} $coldef {} + tcl::dict::for {property val} $coldef { + switch -- $property { + -ansireset {continue} + -headers { + set htable [tcl::dict::get $col_header_tables $col] + tcl::dict::for {innercol maxw} $max_widths { + $htable configure_column $innercol -minwidth $maxw -blockalign left + } + lappend row [$htable print] + $htable destroy + } + default { + lappend row $val + } + } + } + $t add_row $row + } + + + + + $t configure -show_header 1 + puts stdout [$t print] + $t destroy + } + puts stdout "columnstates: $o_columnstates" + puts stdout "headerdefs: $o_headerdefs" + puts stdout "headerstates: $o_headerstates" + tcl::dict::for {k coldef} $o_columndefs { + if {[tcl::dict::exists $o_columndata $k]} { + set headerlist [tcl::dict::get $coldef -headers] + set coldata [tcl::dict::get $o_columndata $k] + set colinfo "rowcount: [llength $coldata]" + set allfields [concat $headerlist $coldata] + if {[llength $allfields]} { + set widest [tcl::mathfunc::max {*}[lmap v $allfields {textblock::width $v}]] + } else { + set widest 0 + } + append colinfo " widest of headers and data: $widest" + } else { + set colinfo "WARNING - no columndata record for column key '$k'" + } + puts stdout "column $k columndata info: $colinfo" + } + set result "" + set cols [list] + set max [expr {[tcl::dict::size $o_columndefs]-1}] + foreach c [tcl::dict::keys $o_columndefs] { + if {$c == 0} { + lappend cols [my get_column_by_index $c -position left] " " + } elseif {$c == $max} { + lappend cols [my get_column_by_index $c -position right] + } else { + lappend cols [my get_column_by_index $c -position inner] " " + } + } + append result [textblock::join -- {*}$cols] + return $result + } + #column width including headers - but without colspan consideration + method column_width_configured {index_expression} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + #assert cidx is now >=0 integer within the range of defined columns + set cdef [tcl::dict::get $o_columndefs $cidx] + set defminw [tcl::dict::get $cdef -minwidth] + set defmaxw [tcl::dict::get $cdef -maxwidth] + if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { + #an exact width is defined for the column - no need to look at data width + set colwidth $defminw + } else { + #set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1] + set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + #set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1] + #set hwidest_singlespan ?? + set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + set widest [expr {max($hwidest,$bwidest)}] + #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. + #if so - a truncated line shouldn't be included in our width calculation + if {$defminw eq ""} { + if {$defmaxw eq ""} { + set colwidth $widest + } else { + set colwidth [expr {min($defmaxw,$widest)}] + } + } else { + if {$defmaxw eq ""} { + set colwidth [expr {max($defminw,$widest)}] + } else { + if {$widest < $defminw} { + set colwidth $defminw + } else { + if {$widest > $defmaxw} { + set colwidth $defmaxw + } else { + set colwidth [expr {max($defminw,$widest)}] + } + } + } + } + } + return $colwidth + } + + 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 + } + return $o_calculated_column_widths + } + + #width of a table includes borders and seps + #whereas width of a column refers to the borderless width (inner width) + method width {} { + #*** !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 + if {[my Showing_vseps]} { + incr twidth [llength $colwidths] + incr twidth -1 + } + if {[tcl::dict::get $o_opts_table -show_edge]} { + incr twidth 2 + } + return $twidth + } + + #column *body* content width + method basic_column_width {index_expression} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + #puts "===column_width $index_expression" + #assert cidx is now >=0 integer within the range of defined columns + set cdef [tcl::dict::get $o_columndefs $cidx] + set defminw [tcl::dict::get $cdef -minwidth] + set defmaxw [tcl::dict::get $cdef -maxwidth] + if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { + #an exact width is defined for the column - no need to look at data width + #review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header + set colwidth $defminw + } else { + #set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0] + set widest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. + #if so - a truncated line shouldn't be included in our width calculation + if {$defminw eq ""} { + if {$defmaxw eq ""} { + set colwidth $widest + } else { + set colwidth [expr {min($defmaxw,$widest)}] + } + } else { + if {$defmaxw eq ""} { + set colwidth [expr {max($defminw,$widest)}] + } else { + if {$widest < $defminw} { + set colwidth $defminw + } else { + if {$widest > $defmaxw} { + set colwidth $defmaxw + } else { + set colwidth [expr {max($defminw,$widest)}] + } + } + } + } + } + set configured_widths [list] + foreach c [tcl::dict::keys $o_columndefs] { + lappend configured_widths [my column_width_configured $c] + } + set header_colspans [my header_colspans] + set width_max $colwidth + set test_width $colwidth + set showing_vseps [my Showing_vseps] + set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + tcl::dict::for {h colspans} $header_colspans { + set spanc [lindex $colspans $cidx] + #set headers [tcl::dict::get $cdef -headers] + #set thiscol_widest_header 0 + #if {[llength $headers] > 0} { + # set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]] + #} + if {$spanc eq "1"} { + if {$thiscol_widest_header > $colwidth} { + set test_width [expr {max($thiscol_widest_header,$colwidth)}] + if {$defmaxw ne ""} { + set test_width [expr {min($colwidth,$defmaxw)}] + } + } + set width_max [expr {max($test_width,$width_max)}] + continue + } + if {$spanc eq "any" || $spanc > 1} { + set spanned [list] ;#spanned is other columns spanned - not including this one + set cnext [expr {$cidx +1}] + set spanlength [lindex $colspans $cnext] + while {$spanlength eq "0" && $cnext < [llength $colspans]} { + lappend spanned $cnext + incr cnext + set spanlength [lindex $colspans $cnext] + } + set others_width 0 + foreach col $spanned { + incr others_width [lindex $configured_widths $col] + if {$showing_vseps} { + incr others_width 1 + } + } + set total_spanned_width [expr {$width_max + $others_width}] + if {$thiscol_widest_header > $total_spanned_width} { + #this just allocates the extra space in the current column - which is not great. + #A proper algorithm for distributing width created by headers to all the spanned columns is needed. + #This is a tricky problem with multiple header lines and arbitrary spans. + #The calculation should probably be done on the table as a whole first and this function should just look up that result. + #Trying to calculate on a specific column only is unlikely to be easy or efficient. + set needed [expr {$thiscol_widest_header - $total_spanned_width}] + #puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)" + if {$defmaxw ne ""} { + set test_width [expr {min($colwidth+$needed,$defmaxw)}] + } else { + set test_width [expr {$colwidth + $needed}] + } + } + } + set width_max [expr {max($test_width,$width_max)}] + } + + #alternative to all the above shennanigans.. let the body cell data determine the size and just wrap the headers + #could also split the needed width amongst the spanned columns? configurable for whether cells expand? + set expand_first_column 1 + if {$expand_first_column} { + set colwidth $width_max + } + + #puts "---column_width $cidx = $colwidth" + return $colwidth + } + method Showing_vseps {} { + #review - show_seps and override mechanism for show_vseps show_hseps - document. + set seps [tcl::dict::get $o_opts_table -show_seps] + set vseps [tcl::dict::get $o_opts_table -show_vseps] + if {$seps eq ""} { + if {$vseps eq "" || $vseps} { + return true + } + } elseif {$seps} { + if {$vseps eq "" || $vseps} { + return true + } + } else { + if {$vseps ne "" && $vseps} { + return true + } + } + return false + } + + method column_datawidth {index_expression args} { + set opts [tcl::dict::create\ + -headers 0\ + -footers 0\ + -colspan unspecified\ + -data 1\ + -cached 1\ + ] + #NOTE: -colspan any is not the same as * + # + #-colspan is relevant to header/footer data only + foreach {k v} $args { + switch -- $k { + -headers - -footers - -colspan - -data - -cached { + tcl::dict::set opts $k $v + } + default { + error "column_datawidth unrecognised flag '$k'. Known flags: [tcl::dict::keys $opts]" + } + } + } + set opt_colspan [tcl::dict::get $opts -colspan] + switch -- $opt_colspan { + * - unspecified {} + any { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0 (use header_colspans_numeric to get actual spans)" + } + default { + if {![string is integer -strict $opt_colspan]} { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0" + } + } + } + + + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + + if {[tcl::dict::get $opts -cached]} { + set hwidest 0 + set bwidest 0 + set fwidest 0 + if {[tcl::dict::get $opts -headers]} { + if {$opt_colspan in {* unspecified}} { + set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + } else { + #this is not cached + # -- --- --- --- + set colheaders [tcl::dict::get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans_numeric] + set hlist [list] + tcl::dict::for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + # -- --- --- --- + } + } + if {[tcl::dict::get $opts -data]} { + set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + } + if {[tcl::dict::get $opts -footers]} { + #TODO! + #set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthfooterseen] + } + return [expr {max($hwidest,$bwidest,$fwidest)}] + } + + #assert cidx is >=0 integer in valid range of keys for o_columndefs + set values [list] + set hwidest 0 + if {[tcl::dict::get $opts -headers]} { + if {$opt_colspan in {* unspecified}} { + lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] + } else { + # -- --- --- --- + set colheaders [tcl::dict::get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans_numeric] + set hlist [list] + tcl::dict::for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + # -- --- --- --- + } + } + if {[tcl::dict::get $opts -data]} { + if {[tcl::dict::exists $o_columndata $cidx]} { + lappend values {*}[tcl::dict::get $o_columndata $cidx] + } + } + if {[tcl::dict::get $opts -footers]} { + lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] + } + if {[llength $values]} { + set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] + set widest [expr {max($valwidest,$hwidest)}] + } else { + set widest $hwidest + } + return $widest + } + #print1 uses basic column joining - useful for testing/debug especially with colspans + method print1 {args} { + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0 } + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set colposn 0 + set numposns [llength $cols] + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + lappend blocks [my get_column_by_index $c {*}$flags] + incr colposn + } + if {[llength $blocks]} { + return [textblock::join -- {*}$blocks] + } else { + return "No columns matched" + } + } + method columncalc_spans {allocmethod} { + set colwidths [tcl::dict::create] ;# to use tcl::dict::incr + set colspace_added [tcl::dict::create] + + set ordered_spans [tcl::dict::create] + tcl::dict::for {col spandata} [my spangroups] { + set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] + set minwidth [tcl::dict::get $o_columndefs $col -minwidth] + set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] + if {$minwidth ne ""} { + if {$dwidth < $minwidth} { + set dwidth $minwidth + } + } + if {$maxwidth ne ""} { + if {$dwidth > $maxwidth} { + set dwidth $maxwidth + } + } + tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered + tcl::dict::set colspace_added $col 0 + + set spanlengths [tcl::dict::get $spandata spanlengths] + foreach slen $spanlengths { + set spans [tcl::dict::get $spandata spangroups $slen] + set spans [lsort -index 7 -integer $spans] + foreach s $spans { + set hwidth [tcl::dict::get $s headerwidth] + set hrow [tcl::dict::get $s hrow] + set scol [tcl::dict::get $s startcol] + tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth + tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth + } + } + } + + #safe jumptable test + #dict for {spanid spandata} $ordered_spans {} + tcl::dict::for {spanid spandata} $ordered_spans { + lassign [split $spanid ,] startcol hrow + set memcols [tcl::dict::get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios + set colids [tcl::dict::keys $memcols] + set hwidth [tcl::dict::get $spandata headerwidth] + set num_cols_spanned [tcl::dict::size $memcols] + if {$num_cols_spanned == 1} { + set col [lindex $memcols 0] + set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] + if {$space_to_alloc > 0} { + set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] + if {$maxwidth ne ""} { + if {$maxwidth > [tcl::dict::get $colwidths $col]} { + set can_alloc [expr {$maxwidth - [tcl::dict::get $colwidths $col]}] + } else { + set can_alloc 0 + } + set will_alloc [expr {min($space_to_alloc,$can_alloc)}] + } else { + set will_alloc $space_to_alloc + } + if {$will_alloc} { + #tcl::dict::set colwidths $col $hwidth + tcl::dict::incr colwidths $col $will_alloc + tcl::dict::set colspace_added $col $will_alloc + } + #log! + #if {$will_alloc < $space_to_alloc} { + # #todo - debug only + # puts stderr "max width $maxwidth hit for col $col - cannot allocate extra [expr {$space_to_alloc - $will_alloc}]" + #} + } + } elseif {$num_cols_spanned > 1} { + set spannedwidth 0 + foreach col $colids { + incr spannedwidth [tcl::dict::get $colwidths $col] + } + set space_to_alloc [expr {$hwidth - $spannedwidth}] + if {[my Showing_vseps]} { + set sepcount [expr {$num_cols_spanned -1}] + incr space_to_alloc -$sepcount + } + #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added + switch -- $allocmethod { + least { + #add to least-expanded each time + #safer than method 1 - pretty balanced + if {$space_to_alloc > 0} { + for {set i 0} {$i < $space_to_alloc} {incr i} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] + foreach testcolid $ordered_all_colids { + if {$testcolid in $colids} { + #assert - we will always find a match + set colid $testcolid + break + } + } + tcl::dict::incr colwidths $colid + tcl::dict::incr colspace_added $colid + } + } + } + least_unmaxed { + #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth + #(we should be able to collapse column width to zero and have header colspans gracefully respond) + #add to least-expanded each time + #safer than method 1 - pretty balanced + if {$space_to_alloc > 0} { + for {set i 0} {$i < $space_to_alloc} {incr i} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] + set colid "" + foreach testcolid $ordered_all_colids { + set maxwidth [tcl::dict::get $o_columndefs $testcolid -maxwidth] + set can_alloc [expr {$maxwidth eq "" || $maxwidth > [tcl::dict::get $colwidths $testcolid]}] + if {$testcolid in $colids} { + if {$can_alloc} { + set colid $testcolid + break + } else { + #remove from future consideration in for loop + #log! + #puts stderr "max width $maxwidth hit for col $testcolid" + tcl::dict::unset colspace_added $testcolid + } + } + } + if {$colid ne ""} { + tcl::dict::incr colwidths $colid + tcl::dict::incr colspace_added $colid + } + } + } + } + all { + #adds space to all columns - not just those spanned - risk of underallocating and truncating some headers! + #probably not a good idea for tables with complex headers and spans + while {$space_to_alloc > 0} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_colids [tcl::dict::keys $ordered_colspace_added] + + foreach col $ordered_colids { + tcl::dict::incr colwidths $col + tcl::dict::incr colspace_added $col + incr space_to_alloc -1 + if {$space_to_alloc == 0} { + break + } + } + } + + } + } + } + } + + set column_widths [tcl::dict::values $colwidths] + #todo - -maxwidth etc + set table_minwidth [tcl::dict::get $o_opts_table -minwidth] ;#min width including frame elements + if {[tcl::string::is integer -strict $table_minwidth]} { + set contentwidth [tcl::mathop::+ {*}$column_widths] + set twidth $contentwidth + if {[my Showing_vseps]} { + incr twidth [llength $column_widths] + incr twidth -1 + } + if {[tcl::dict::get $o_opts_table -show_edge]} { + incr twidth 2 + } + # + set shortfall [expr {$table_minwidth - $twidth}] + if {$shortfall > 0} { + set space_to_alloc $shortfall + while {$space_to_alloc > 0} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_colids [tcl::dict::keys $ordered_colspace_added] + + foreach col $ordered_colids { + tcl::dict::incr colwidths $col + tcl::dict::incr colspace_added $col + incr space_to_alloc -1 + if {$space_to_alloc == 0} { + break + } + } + } + set column_widths [tcl::dict::values $colwidths] + } + + } + + return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] + } + + #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 + foreach c [tcl::dict::keys $o_columndefs] { + tcl::dict::set spangroups $c [list spanlengths {}] + set spanlist [my column_get_spaninfo $c] + set index_spanlen_val 5 + set spanlist [lsort -index $index_spanlen_val -integer $spanlist] + set ungrouped $spanlist + + while {[llength $ungrouped]} { + set spanlen [lindex $ungrouped 0 $index_spanlen_val] + set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen] + set sgroup [list] + foreach p $spangroup_posns { + set spaninfo [lindex $ungrouped $p] + set hcol [tcl::dict::get $spaninfo startcol] + set hrow [tcl::dict::get $spaninfo hrow] + set header [lindex [tcl::dict::get $o_columndefs $hcol -headers] $hrow] + if {[tcl::dict::exists $headerwidths $hcol,$hrow]} { + set hwidth [tcl::dict::get $headerwidths $hcol,$hrow] + } else { + set hwidth [textblock::width $header] + tcl::dict::set headerwidths $hcol,$hrow $hwidth + } + lappend spaninfo headerwidth $hwidth + lappend sgroup $spaninfo + } + set spanlengths [tcl::dict::get $spangroups $c spanlengths] + lappend spanlengths $spanlen + tcl::dict::set spangroups $c spanlengths $spanlengths + tcl::dict::set spangroups $c spangroups $spanlen $sgroup + set ungrouped [lremove $ungrouped {*}$spangroup_posns] + } + } + return $spangroups + } + method column_get_own_spans {cidx} { + set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] + } + method column_get_spaninfo {cidx} { + set spans_by_header [my header_colspans] + set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] + set spaninfo [list] + set numcols [tcl::dict::size $o_columndefs] + #note that 'any' can occur in positions other than column 0 - meaning any remaining until next non-zero span + tcl::dict::for {hrow rawspans} $spans_by_header { + set thiscol_spanval [lindex $rawspans $cidx] + if {$thiscol_spanval eq "any" || $thiscol_spanval > 0} { + set spanstartcol $cidx ;#own column + if {$thiscol_spanval eq "any"} { + #scan right to first non-zero to get actual length of 'any' span + #REVIEW! + set spanlen 1 + for {set i [expr {$cidx+1}]} {$i < $numcols} {incr i} { + #abort at next any or number or empty string + if {[lindex $rawspans $i] ne "0"} { + break + } + incr spanlen + } + #set spanlen [expr {$numcols - $cidx}] + } else { + set spanlen $thiscol_spanval + } + } else { + #look left til we see an any or a non-zero value + for {set i $cidx} {$i > -1} {incr i -1} { + set s [lindex $rawspans $i] + if {$s eq "any" || $s > 0} { + set spanstartcol $i + if {$s eq "any"} { + #REVIEW! + #set spanlen [expr {$numcols - $i}] + set spanlen 1 + #now scan right to see how long the 'any' actually is + for {set j [expr {$i+1}]} {$j < $numcols} {incr j} { + if {[lindex $rawspans $j] ne "0"} { + break + } + incr spanlen + } + } else { + set spanlen $s + } + break + } + } + } + #assert - we should always find 1 answer for each header row + lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen] + } + return $spaninfo + } + method calculate_column_widths {args} { + set column_count [tcl::dict::size $o_columndefs] + + set opts [tcl::dict::create\ + -algorithm $o_column_width_algorithm\ + ] + foreach {k v} $args { + switch -- $k { + -algorithm { + tcl::dict::set opts $k $v + } + default { + error "Unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + set opt_algorithm [tcl::dict::get $opts -algorithm] + #puts stderr "--- recalculating column widths -algorithm $opt_algorithm" + set known_algorithms [list basic simplistic span span2] + switch -- $opt_algorithm { + basic { + #basic column by column - This allocates extra space to first span/column as they're encountered. + #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans + #The header values can extend over some of the spanned columns - but not optimally so. + set o_calculated_column_widths [list] + for {set c 0} {$c < $column_count} {incr c} { + lappend o_calculated_column_widths [my basic_column_width $c] + } + } + simplistic { + #just uses the widest column data or header element. + #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column + #This is a conservative option potentially useful in testing/debugging. + set o_calculated_column_widths [list] + for {set c 0} {$c < $column_count} {incr c} { + lappend o_calculated_column_widths [my column_width_configured $c] + } + } + span { + #widest of smallest spans first method + #set calcresult [my columncalc_spans least] + set calcresult [my columncalc_spans least_unmaxed] + set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] + } + span2 { + #allocates more evenly - but truncates headers sometimes + set calcresult [my columncalc_spans all] + set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] + } + default { + error "calculate_column_widths unknown algorithm $opt_algorithm. Known algorithms: $known_algorithms" + } + } + #remember the last algorithm used + set o_column_width_algorithm $opt_algorithm + return $o_calculated_column_widths + } + method print2 {args} { + variable full_column_cache + set full_column_cache [tcl::dict::create] + + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set colposn 0 + set numposns [llength $cols] + set padwidth 0 + set table "" + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + #lappend blocks [my get_column_by_index $c {*}$flags] + #todo - only check and store in cache if table has header or footer colspans > 1 + if {[tcl::dict::exists $full_column_cache $c]} { + #puts "!!print used full_column_cache for $c" + set columninfo [tcl::dict::get $full_column_cache $c] + } else { + set columninfo [my get_column_by_index $c -return dict {*}$flags] + tcl::dict::set full_column_cache $c $columninfo + } + set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] + set bodywidth [tcl::dict::get $columninfo bodywidth] + + if {$table eq ""} { + set table $nextcol + set height [textblock::height $table] ;#only need to get height once at start + } else { + set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] + set table [overtype::renderspace -expand_right 1 -transparent $TSUB $table[unset table] $nextcol] + #JMN + + #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] + #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] + } + incr padwidth $bodywidth + incr colposn + } + + if {[llength $cols]} { + #return [textblock::join -- {*}$blocks] + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + + # using -startcolumn to do slightly less work + method print3 {args} { + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set numposns [llength $cols] + set colposn 0 + set padwidth 0 + set table "" + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + set columninfo [my get_column_by_index $c -return dict {*}$flags] + set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] + set bodywidth [tcl::dict::get $columninfo bodywidth] + + if {$table eq ""} { + set table $nextcol + set height [textblock::height $table] ;#only need to get height once at start + } else { + set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] + } + incr padwidth $bodywidth + incr colposn + } + + if {[llength $cols]} { + #return [textblock::join -- {*}$blocks] + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + + #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 { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set numposns [llength $cols] + set colposn 0 + set padwidth 0 + set header_build "" + set body_blocks [list] + set headerheight 0 + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + set columninfo [my get_column_by_index $c -return dict {*}$flags] + #set nextcol [tcl::dict::get $columninfo column] + set bodywidth [tcl::dict::get $columninfo bodywidth] + set headerheight [tcl::dict::get $columninfo headerheight] + #set nextcol_lines [split $nextcol \n] + #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] + #set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n] + set nextcol_header [tcl::dict::get $columninfo header] + set nextcol_body [tcl::dict::get $columninfo body] + + if {$header_build eq "" && ![llength $body_blocks]} { + set header_build $nextcol_header + } else { + if {$headerheight > 0} { + set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] + } + #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] + } + lappend body_blocks $nextcol_body + incr padwidth $bodywidth + incr colposn + } + if {![llength $body_blocks]} { + set body_build "" + } else { + #body blocks should not be ragged - so can use join_basic + set body_build [textblock::join_basic -- {*}$body_blocks] + } + if {$headerheight > 0} { + set table [tcl::string::cat $header_build \n $body_build] + } else { + set table $body_build + } + + if {[llength $cols]} { + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + 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 + } + + #*** !doctools + #[list_end] + }] + #*** !doctools + # [list_end] [comment {- end enumeration provider_classes }] + #[list_end] [comment {- end itemized list textblock::class groupings -}] + } + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# +#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 *} + tcl::namespace::import ::term::ansi::code::macros::cd::* + tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} + } + proc spantest {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2] + $t configure_column 0 -header_colspans {3 4 5 any 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + proc spantest1 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers [list "span3-any longer than other span any" "1-span4\n2-span4 second line" "span-any short aligned?" "span5/5 longest etc blah 123" span2] + $t configure_column 0 -header_colspans {any 4 any 5 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 0 0 0} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + $t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs) + return $t + } + + #more complex colspans + proc spantest2 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} + $t configure_column 0 -header_colspans {3 4 1 any 2} + $t configure_column 1 -header_colspans {0 0 2 0 0} + $t configure_column 2 -headers {"" "" "" "" c2span2} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 2 0 0} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + proc spantest3 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1} + $t configure_column 0 -header_colspans {3 4 1 any 2 1} + $t configure_column 1 -header_colspans {0 0 4 0 0 1} + $t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"} + $t configure_column 2 -headers {"" "" "" "" "" c2span2} + $t configure_column 2 -header_colspans {0 0 0 0 1 2} + $t configure_column 4 -headers {"4" "444" "" "" "" "44"} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + + punk::args::define { + @id -id ::textblock::periodic + @cmd -name textblock::periodic -help "A rudimentary periodic table + This is primarily a test of textblock::class::table" + + -return -default table\ + -choices {table tableobject}\ + -help "default choice 'table' returns the displayable table output" + -compact -default 1 -type boolean -help "compact true defaults: -show_vseps 0 -show_header 0 -show_edge 0" + -frame -default 1 -type boolean + -show_vseps -default "" -type boolean + -show_header -default "" -type boolean + -show_edge -default "" -type boolean + -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" + @values -min 0 -max 0 + } + + proc periodic {args} { + #For an impressive interactive terminal app (javascript) + # see: https://github.com/spirometaxas/periodic-table-cli + set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + set opt_return [tcl::dict::get $opts -return] + if {[tcl::dict::get $opts -forcecolour]} { + set fc forcecolour + } else { + set fc "" + } + + #examples ptable.com + set elements [list\ + 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ + 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ + 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ + 4 K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr\ + 5 Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe\ + 6 Cs Ba "" Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn\ + 7 Fr Ra "" Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og\ + " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ + "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ + "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ + ] + + set type_colours [list] + + set ecat [tcl::dict::create] + + set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] + set ansi [a+ {*}$fc web-black Web-gold] + set val [list ansi $ansi cat alkaline_earth] + foreach e $cat_alkaline_earth { + tcl::dict::set ecat $e $val + } + + set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] + #set ansi [a+ {*}$fc web-black Web-lightgreen] + set ansi [a+ {*}$fc black Term-113] + set val [list ansi $ansi cat reactive_nonmetal] + foreach e $cat_reactive_nonmetal { + tcl::dict::set ecat $e $val + } + + set cat [list Li Na K Rb Cs Fr] + #set ansi [a+ {*}$fc web-black Web-Khaki] + set ansi [a+ {*}$fc black Term-lightgoldenrod2] + set val [list ansi $ansi cat alkali_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] + #set ansi [a+ {*}$fc web-black Web-lightsalmon] + set ansi [a+ {*}$fc black Term-orange1] + set val [list ansi $ansi cat transition_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Al Ga In Sn Tl Pb Bi Po] + set ansi [a+ {*}$fc web-black Web-lightskyblue] + set val [list ansi $ansi cat post_transition_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list B Si Ge As Sb Te At] + #set ansi [a+ {*}$fc web-black Web-turquoise] + set ansi [a+ {*}$fc black Brightcyan] + set val [list ansi $ansi cat metalloids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list He Ne Ar Kr Xe Rn] + set ansi [a+ {*}$fc web-black Web-orchid] + set val [list ansi $ansi cat noble_gases] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] + set ansi [a+ {*}$fc web-black Web-plum] + set val [list ansi $ansi cat actinoids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] + #set ansi [a+ {*}$fc web-black Web-tan] + set ansi [a+ {*}$fc black Term-tan] + set val [list ansi $ansi cat lanthanoids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set ansi [a+ {*}$fc web-black Web-whitesmoke] + set val [list ansi $ansi cat other] + foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { + tcl::dict::set ecat $e $val + } + + set elements1 [list] + set RST [a+] + foreach e $elements { + if {[tcl::dict::exists $ecat $e]} { + set ansi [tcl::dict::get $ecat $e ansi] + #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] + #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway + lappend elements1 $ansi$e + } else { + lappend elements1 $e + } + } + + set t [list_as_table -columns 19 -return tableobject $elements1] + #(defaults to show_hseps 0) + + #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options + + set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] + set c 0 + foreach h $header_0 { + $t configure_column $c -headers [list $h] -minwidth 2 + incr c + } + set ccount [$t column_count] + for {set c 0} {$c < $ccount} {incr c} { + $t configure_column $c -minwidth 3 + } + if {[tcl::dict::get $opts -compact]} { + #compact defaults - but let explicit arguments override + set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0] + } else { + set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1] + } + dict for {k v} $conf { + if {[dict get $opts $k] ne ""} { + dict set conf $k [dict get $opts $k] + } + } + + set moreopts [dict create\ + -frametype_header light\ + -ansiborder_header [a+ {*}$fc brightwhite]\ + -ansibase_header [a+ {*}$fc Black]\ + -ansibase_body [a+ {*}$fc Black]\ + -ansiborder_body [a+ {*}$fc black]\ + -frametype block + ] + $t configure {*}[dict merge $conf $moreopts] + + #-ansiborder_header [a+ {*}$fc web-white]\ + + if {$opt_return eq "table"} { + 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 -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + } else { + set output [$t print] + } + $t destroy + return $output + } + return $t + } + + proc bookend_lines {block start {end "\x1b\[m"}} { + set out "" + foreach ln [split $block \n] { + append out $start $ln $end \n + } + return [string range $out 0 end-1] + } + proc ansibase_lines {block {newprefix ""}} { + set base "" + set out "" + if {$newprefix eq ""} { + if {![punk::ansi::ta::detect $block]} { + return $block + } + foreach ln [split $block \n] { + set parts [punk::ansi::ta::split_codes $ln] + if {[lindex $parts 0] eq ""} { + if {[lindex $parts 1] ne "" && ![punk::ansi::codetype::is_sgr_reset [lindex $parts 1]]} { + set base [lindex $parts 1] + append out $base + } else { + append out $base + } + } else { + #leading plaintext - maintain our base + append out $base [lindex $parts 0] [lindex $parts 1] + } + + set code_idx 3 + foreach {pt code} [lrange $parts 2 end] { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set parts [linsert $parts $code_idx+1 $base] + } + incr code_idx 2 + } + append out {*}[lrange $parts 2 end] \n + } + return [string range $out 0 end-1] + } else { + set base $newprefix + if {![punk::ansi::ta::detect $block]} { + foreach ln [split $block \n] { + append out $base $ln \n + } + return $out + } + foreach ln [split $block \n] { + set parts [punk::ansi::ta::split_codes $ln] + set code_idx 1 + set offset 0 + foreach {pt code} $parts { + if {$code_idx == 1} { + #first pt & code + if {$pt ne ""} { + #leading plaintext + set parts [linsert $parts 0 $base] + incr offset + } + } + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set parts [linsert $parts [expr {$code_idx+1+$offset}] $base] + incr offset + } + incr code_idx 2 + } + append out {*}$parts \n + } + return [string range $out 0 end-1] + } + } + + set FRAMETYPES [textblock::frametypes] + punk::args::define [punk::lib::tstr -return string { + @id -id ::textblock::list_as_table + @cmd -name "textblock::list_as_table" -help\ + "Display a list in a bordered 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 "Each supplied -header argument is a header row. + The number of values for each must be <= number of columns" + -show_header -type boolean\ + -help "Whether to show a header row. + Omit 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 + Will default to 2 if not using an existing -table object" + + @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_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 count [llength $datalist] + + set is_new_table 0 + if {$existing_table ne ""} { + if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} { + error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])" + } + set t $existing_table + foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} { + if {[tcl::dict::get $opts $prop] ne ""} { + $t configure $prop [tcl::dict::get $opts $prop] + } + } + if {[dict get $opts -action] eq "replace"} { + $t row_clear + } + set cols [$t column_count] + if {[tcl::string::is integer -strict $opt_columns]} { + if {$opt_columns > $cols} { + set extra [expr {$opt_columns - $cols}] + for {set c 0} {$c < $extra} {incr c} { + $t add_column + } + } elseif {$opt_columns < $cols} { + #todo - auto add blank values in the datalist + error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported" + } + set cols [$t column_count] + } + } else { + set is_new_table 1 + set colheaders {} + if {[tcl::dict::get $opts -colheaders] ne ""} { + set colheaders [dict get $opts -colheaders] + } else { + set colheaders [list] + } + set r 0 + foreach ch $colheaders { + set rows [llength $ch] + if {$r < $rows} { + set r $rows + } + } + if {[llength [tcl::dict::get $opts -header]]} { + foreach hrow [tcl::dict::get $opts -header] { + set c 0 + foreach cell $hrow { + if {[llength $colheaders] < $c+1} { + lappend colheaders [lrepeat $r {}] + } + set colinfo [lindex $colheaders $c] + if {$r > [llength $colinfo]} { + set diff [expr {$r - [llength $colinfo]}] + lappend colinfo {*}[lrepeat $diff {}] + } + lappend colinfo $cell + lset colheaders $c $colinfo + incr c + } + incr r + } + } + + + if {[llength $colheaders] > 0} { + if {![tcl::dict::exists $opts received -show_header]} { + set show_header 1 + } else { + set show_header [tcl::dict::get $opts -show_header] + } + } else { + if {![tcl::dict::exists $opts received -show_header]} { + set show_header 0 + } else { + set show_header [tcl::dict::get $opts -show_header] + } + } + + if {[tcl::string::is integer -strict $opt_columns]} { + set cols $opt_columns + if {[llength $colheaders] && $cols != [llength $colheaders]} { + error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $colheaders])" + } + } else { + #review + if {[llength $colheaders]} { + set cols [llength $colheaders] + } else { + set cols 2 ;#seems a reasonable default + } + } + #defaults for new table only + #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_vseps] eq ""} { + tcl::dict::set opts -show_vseps 1 + } + if {[tcl::dict::get $opts -show_hseps] eq ""} { + tcl::dict::set opts -show_hseps 0 + } + + set t [textblock::class::table new\ + -show_header $show_header\ + -show_edge [tcl::dict::get $opts -show_edge]\ + -frametype [tcl::dict::get $opts -frametype]\ + -show_seps [tcl::dict::get $opts -show_seps]\ + -show_vseps [tcl::dict::get $opts -show_vseps]\ + -show_hseps [tcl::dict::get $opts -show_hseps]\ + ] + if {[llength $colheaders]} { + for {set c 0} {$c < $cols} {incr c} { + $t add_column -headers [lindex $colheaders $c] + } + } else { + for {set c 0} {$c < $cols} {incr c} { + $t add_column -headers [list $c] + } + } + } + + set full_rows [expr {$count / $cols}] + set last_items [expr {$count % $cols}] + + + set rowdata [list] + set row [list] + set i 0 + if {$full_rows > 0} { + for {set r 0} {$r < $full_rows} {incr r} { + set j [expr {$i + ($cols -1)}] + set row [lrange $datalist $i $j] + incr i $cols + lappend rowdata $row + } + } + if {$last_items > 0} { + set idx [expr {$last_items -1}] + lappend rowdata [lrange $datalist end-$idx end] + } + foreach row $rowdata { + set shortfall [expr {$cols - [llength $row]}] + if {$shortfall > 0} { + #set row [concat $row [lrepeat $shortfall ""]] + lappend row {*}[lrepeat $shortfall ""] + } + $t add_row $row + } + #puts stdout $rowdata + if {[tcl::dict::get $opts -return] eq "table"} { + set result [$t print] + if {$is_new_table} { + $t destroy + } + return $result + } else { + return $t + } + } + #return a homogenous block of characters - ie lines all same length, all same character + #printing-width in terminal columns is not necessarily same as blockwidth even if a single char is passed (could be full-width unicode character) + #This can have ansi SGR codes - but to repeat blocks containing ansi-movements, the block should first be rendered to a static output with something like overtype::left + proc block {blockwidth blockheight {char " "}} { + if {$blockwidth < 0} { + error "textblock::block blockwidth must be an integer greater than or equal to zero" + } + if {$blockheight <= 0} { + error "textblock::block blockheight must be a positive integer" + } + if {$char eq ""} {return ""} + #using tcl::string::length is ok + if {[tcl::string::length $char] == 1} { + set row [tcl::string::repeat $char $blockwidth] + set mtrx [lrepeat $blockheight $row] + return [::join $mtrx \n] + } else { + set charblock [tcl::string::map [list \r\n \n] $char] + if {[tcl::string::last \n $charblock] >= 0} { + if {$blockwidth > 1} { + #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) + set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] + } else { + set row $charblock + } + } else { + set row [tcl::string::repeat $char $blockwidth] + } + set mtrx [lrepeat $blockheight $row] + return [::join $mtrx \n] + } + } + + + punk::args::define { + @id -id ::textblock::testblock + @cmd -name textblock::testblock -help\ + "Create a block of characters size + columns wide and size rows tall. + (which on a terminal will show as a + vertically oriented rectangle due to + cells being taller than their width) + + The characters used are + 123456789ABCDEF + " + -size -type integer\ + -default 15\ + -optional 1\ + -range {1 15} + -direction -default horizontal\ + -choices {horizontal vertical}\ + -help\ + "When rainbow is in the colour list, + this also affects the direction of + colour changes" + @values -min 0 -max 2 + colour -type list -default {} -optional 1 -help\ + "List of Ansi colour names + e.g. testblock 10 {white Red} + produces a block of character 10x10 + with white text on red bacground + + The additional pseudo-color 'rainbow' + is available. + " + } + + proc testblock {args} { + set argd [punk::args::get_by_id ::textblock::testblock $args] + set colour [dict get $argd values colour] + set size [dict get $argd opts -size] + + set rainbow_list [list] + lappend rainbow_list {30 47} ;#black White + lappend rainbow_list {31 46} ;#red Cyan + lappend rainbow_list {32 45} ;#green Purple + lappend rainbow_list {33 44} ;#yellow Blue + lappend rainbow_list {34 43} ;#blue Yellow + lappend rainbow_list {35 42} ;#purple Green + lappend rainbow_list {36 41} ;#cyan Red + lappend rainbow_list {37 40} ;#white Black + lappend rainbow_list {black Yellow} + lappend rainbow_list red + lappend rainbow_list green + lappend rainbow_list yellow + lappend rainbow_list blue + lappend rainbow_list purple + lappend rainbow_list cyan + lappend rainbow_list {white Red} + + #set rainbow_direction "horizontal" + #set vpos [lsearch $colour vertical] + #if {$vpos >= 0} { + # set rainbow_direction vertical + # set colour [lremove $colour $vpos] + #} + #set hpos [lsearch $colour horizontal] + #if {$hpos >=0} { + # #horizontal is the default and superfluous but allowed for symmetry + # set colour [lremove $colour $hpos] + #} + set direction [dict get $argd opts -direction] + + + + 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 "" + } else { + set RST [a] + } + if {"rainbow" in $colour && $direction eq "vertical"} { + #column first - colour change each column + set c [::join $charsubset \n] + + set clist [list] + for {set i 0} {$i <$size} {incr i} { + set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] + set ansi [a+ {*}$colour2] + + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] + lappend clist ${ansicode}$c$RST + } + if {"noreset" in $colour} { + return [textblock::join_basic -ansiresets 0 -- {*}$clist] + } else { + return [textblock::join_basic -- {*}$clist] + } + } elseif {"rainbow" in $colour} { + #direction must be horizontal + set block "" + for {set r 0} {$r < $size} {incr r} { + set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] + set ansi [a+ {*}$colour2] + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] + set row "$ansicode" + foreach c $charsubset { + append row $c + } + append row $RST + append block $row\n + } + set block [tcl::string::trimright $block \n] + return $block + } else { + #row first - + set rows [list] + foreach ch $charsubset { + lappend rows [tcl::string::repeat $ch $size] + } + set block [::join $rows \n] + if {$colour ne ""} { + set block [a+ {*}$colour]$block$RST + } + return $block + } + } + interp alias {} testblock {} textblock::testblock + + #todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table + proc width {textblock} { + #backspaces, vertical tabs ? + if {$textblock eq ""} { + return 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 {[string length $textblock] > 1 && [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}]] + } + 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 {[string length $textblock] > 1 && [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] + if {$firstnl >= 0} { + set tl [tcl::string::range $textblock 0 $firstnl] + } else { + set tl $textblock + } + if {[punk::ansi::ta::detect $tl]} { + set tl [punk::ansi::ansistripraw $tl] + } + return [punk::char::ansifreestring_width $tl] + } + #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. + proc string_length_line_max {textblock} { + #tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + set max 0 + foreach ln [split $textblock \n] { + if {[tcl::string::length $ln] > $max} {set max [tcl::string::length $ln]} + } + return $max + } + #*slightly* slower + #proc string_length_line_max {textblock} { + # tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + #} + proc string_length_line_min textblock { + tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + } + + proc height {textblock} { + #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le + #empty string still has height 1 (at least for left-right/right-left languages) + + #vertical tab on a proper terminal should move directly down. + #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) + + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + } + #MAINTENANCE - same as overtype::blocksize? + proc size {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack + 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] + } + #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests + if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] + set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + } else { + set width [punk::char::ansifreestring_width $textblock] + } + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height + } + proc size2 {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack + 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] + } + #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests + if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] + set lines [split $textblock \n] + set num_le [expr {[llength $lines]-1}] + #set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]] + set width 0 + foreach ln $lines { + set w [::punk::char::ansifreestring_width $ln] + if {$w > $width} { + set width $w + } + } + } else { + set num_le 0 + set width [punk::char::ansifreestring_width $textblock] + } + #set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height + } + proc size_as_opts {textblock} { + set sz [size $textblock] + return [dict create -width [dict get $sz width] -height [dict get $sz height]] + } + proc size_as_list {textblock} { + set sz [size $textblock] + return [list [dict get $sz width] [dict get $sz height]] + } + #must be able to handle block as string with or without newlines + #if no newlines - attempt to treat as a list + #must handle whitespace-only string,list elements, and/or lines. + #reviewing 2024 - this seems like too much magic! + proc width1 {block} { + if {$block eq ""} { + return 0 + } + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set block [textutil::tabify::untabify2 $block $tw] + if {[tcl::string::last \n $block] >= 0} { + return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]] + } + if {[catch {llength $block}]} { + return [::punk::char::string_width [ansistrip $block]] + } + if {[llength $block] == 0} { + #could be just a whitespace string + return [tcl::string::length $block] + } + return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]] + } + + #we shouldn't make textblock depend on the punk pipeline system + #pipealias ::textblock::padleft .= {list $input [tcl::string::repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" + foreach {k v} $args { + switch -- $k { + -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { + tcl::dict::set opts $k $v + } + default { + error "textblock::pad unrecognised option '$k'. Usage: $usage" + } + } + } + # -- --- --- --- --- --- --- --- --- --- + set padchar [tcl::dict::get $opts -padchar] + #if padchar width (screen width) > 1 - length calculations will not be correct + #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map + #The caller may also use ansi within the padchar - although it's unlikely to be efficient. + # -- --- --- --- --- --- --- --- --- --- + set known_whiches [list l left r right c center centre] + set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] + switch -- $opt_which { + center - centre - c { + set which c + } + left - l { + set which l + } + right - r { + set which r + } + default { + error "textblock::pad unrecognised value for -which option. Known values $known_whiches" + } + } + # -- --- --- --- --- --- --- --- --- --- + set opt_width [tcl::dict::get $opts -width] + switch -- $opt_width { + "" - auto { + set width auto + } + default { + if {![tcl::string::is integer -strict $opt_width] || $opt_width < 0} { + error "textblock::pad -width must be an integer >=0" + } + set width $opt_width + } + } + # -- --- --- --- --- --- --- --- --- --- + set opt_withinansi [tcl::dict::get $opts -within_ansi] + switch -- $opt_withinansi { + 0 - 1 {} + default { + set opt_withinansi 2 + } + } + # -- --- --- --- --- --- --- --- --- --- + 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"} { + #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] + + set padcharsize [punk::ansi::printing_length $padchar] + set pad_has_ansi [punk::ansi::ta::detect $padchar] + if {$block eq ""} { + #we need to treat as a line + set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + #TODO + #review - what happens when padchar has ansi, or the width would split a double-wide unicode char? + #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) + #we should use overtype with suitable replacement char (space?) for chopped double-wides + if {!$pad_has_ansi} { + return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] + } else { + set base [tcl::string::repeat " " $width] + return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + } + + #review - tcl format can only pad with zeros or spaces? + #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 + #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 + + 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 + foreach {pt ansi} $parts { + if {$pt ne ""} { + set has_nl [expr {[tcl::string::last \n $pt]>=0}] + if {$has_nl} { + set pt [tcl::string::map [list \r\n \n] $pt] + set partlines [split $pt \n] + } else { + set partlines [list $pt] + } + set last [expr {[llength $partlines]-1}] + set p 0 + foreach pl $partlines { + lappend line_chunks $pl + #incr line_len [punk::char::ansifreestring_width $pl] + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + } + if {$p != $last} { + #do padding + 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 + + #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars + if {[tcl::dict::exists $pad_cache $missing]} { + set pad [tcl::dict::get $pad_cache $missing] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + dict set pad_cache $missing $pad + } + switch -- $which-$opt_withinansi { + r-0 { + lappend line_chunks $pad + } + r-1 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + } + r-2 { + lappend line_chunks $pad + } + l-0 { + set line_chunks [linsert $line_chunks 0 $pad] + } + l-1 { + if {[lindex $line_chunks 0] eq ""} { + set line_chunks [linsert $line_chunks 2 $pad] + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + l-2 { + if {$lnum == 0} { + if {[lindex $line_chunks 0] eq ""} { + set line_chunks [linsert $line_chunks 2 $pad] + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + } + } + lappend lines [::join $line_chunks ""] + set line_chunks [list] + set line_len 0 + incr lnum + } + incr p + } + } else { + #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes + lappend line_chunks "" + } + #don't let trailing empty ansi affect the line_chunks length + if {$ansi ne ""} { + lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? + } + } + #pad last line + 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] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + } + #set pad [tcl::string::repeat $padchar $missing] + switch -- $which-$opt_withinansi { + r-0 { + lappend line_chunks $pad + } + r-1 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + } + r-2 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + #lappend line_chunks $pad + } + l-0 { + #if {[lindex $line_chunks 0] eq ""} { + # set line_chunks [linsert $line_chunks 2 $pad] + #} else { + # set line_chunks [linsert $line_chunks 0 $pad] + #} + set line_chunks [linsert $line_chunks 0 $pad] + } + l-1 { + #set line_chunks [linsert $line_chunks 0 $pad] + set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] + } + l-2 { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + } + lappend lines [::join $line_chunks ""] + return [::join $lines \n] + } + + #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single + #resulting list is no longer a valid ansisplit list + proc _insert_before_text_or_last_ansi {str ansisplits} { + if {[llength $ansisplits] == 1} { + #ansisplits was a split on plaintext only + return [list $str [lindex $ansisplits 0]] + } elseif {[llength $ansisplits] == 0} { + return [list $str] + } + if {[llength $ansisplits] %2 != 1} { + error "_insert_before_text_or_last_ansi ansisplits list is not a valid resultlist from an ansi split - must be odd number of elements pt,ansi,pt,ansi...pt" + } + set out [list] + set i 0 + set i_last_code [expr {[llength $ansisplits]-3}] ;#would normally be -2 - but our i is jumping to each pt - not every element + foreach {pt code} $ansisplits { + if {$pt ne ""} { + return [lappend out $str {*}[lrange $ansisplits $i end]] + } + if {$i == $i_last_code} { + return [lappend out $str {*}[lrange $ansisplits $i end]] + } + #code being empty can only occur when we have reached last pt + #we have returned by then. + lappend out $code + incr i 2 + } + error "_insert_before_text_or_last_ansi failed on input str:[ansistring VIEW $str] ansisplits:[ansistring VIEW $ansisplits]" + } + proc pad_test {block} { + set width [textblock::width $block] + set padtowidth [expr {$width + 10}] + 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] + + set t [textblock::list_as_table -columns 3 -return tableobject $testlist] + $t configure_column 0 -headers [list "ansi"] + $t configure_column 1 -headers [list "Left"] + $t configure_column 2 -headers [list "Right"] + $t configure -show_header 1 + puts stdout [$t print] + return $t + } + + proc pad_test_blocklist {blocklist args} { + set opts [tcl::dict::create\ + -description ""\ + -blockheaders ""\ + ] + foreach {k v} $args { + switch -- $k { + -description - -blockheaders { + tcl::dict::set opts $k $v + } + default { + error "pad_test_blocklist unrecognised option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + set opt_blockheaders [tcl::dict::get $opts -blockheaders] + set bheaders [tcl::dict::create] + if {$opt_blockheaders ne ""} { + set b 0 + foreach h $opt_blockheaders { + if {$b < [llength $blocklist]} { + tcl::dict::set bheaders $b $h + } + incr b + } + } + + set b 0 + set blockinfo [tcl::dict::create] + foreach block $blocklist { + set width [textblock::width $block] + tcl::dict::set blockinfo $b width $width + set padtowidth [expr {$width + 3}] + tcl::dict::set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] + tcl::dict::set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] + tcl::dict::set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] + tcl::dict::set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] + tcl::dict::set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] + tcl::dict::set blockinfo $b right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] + incr b + } + + set r0 [list "0"] + set r1 [list "1"] + set r2 [list "2"] + set r3 [list "column\ncolours"] + + #1 + #test without table padding + #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering + #(basically a mechanism to add extra resets at start and end of each line) + #dict for {b bdict} $blockinfo { + # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] + # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] + # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] + #} + + #2 - the more useful one? + tcl::dict::for {b bdict} $blockinfo { + lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] + lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] + lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] + lappend r3 "" "" + } + + set rows [concat $r0 $r1 $r2 $r3] + + set column_ansi [a+ web-white Web-Gray] + + set t [textblock::list_as_table -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows] + $t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi + set col 1 + tcl::dict::for {b bdict} $blockinfo { + if {[tcl::dict::exists $bheaders $b]} { + set hdr [tcl::dict::get $bheaders $b] + } else { + set hdr "Block $b" + } + $t configure_column $col -headers [list $hdr "Left"] -minwidth [expr {$padtowidth + 2}] + $t configure_column $col -header_colspans 2 -ansibase $column_ansi + incr col + $t configure_column $col -headers [list "-" "Right"] -minwidth [expr {$padtowidth + 2}] -ansibase $column_ansi + incr col + } + $t configure -show_header 1 + puts stdout [$t print] + return $t + } + proc pad_example {} { + set headers [list] + set blocks [list] + + lappend blocks "[textblock::testblock 4 rainbow]" + lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" + + lappend blocks "[textblock::testblock 4 rainbow][a]" + lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" + + lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" + lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}]" + lappend headers "rainbow 4x4\nno line resets\nnothing trailing" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" + lappend headers "rainbow 4x4\nno line resets\ntrailing reset" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" + lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" + + set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] + } + proc pad_example2 {} { + set headers [list] + set blocks [list] + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" + + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" + + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" + + set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] + } + + + #playing with syntax + + # pipealias ::textblock::join_width .= {list $lhs [tcl::string::repeat " " $w1] $rhs [tcl::string::repeat " " $w2]} {| + # /2,col1/1,col2/3 + # >} punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| + # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| + # >} punk::lib::list_as_lines -- $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} { + #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. + # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner + #" + 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 + } + set idx 0 + set fordata [list] + set colindices [list] + foreach b $blocks { + if {[punk::ansi::ta::detect $b]} { + lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] + } else { + lappend fordata "v($idx)" [split $b \n] + } + lappend colindices $idx + incr idx + } + set outlines [list] + foreach {*}$fordata { + set row {} + foreach colidx $colindices { + lappend row $v($colidx) + } + lappend outlines [::join $row ""] + } + return [::join $outlines \n] + } + #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed + #they may however still be 'ragged' ie differing line lengths + proc ::textblock::join {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 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] + 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] + } 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 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 " "] + } + lappend outlines $row + } + #puts stderr "--->outlines len: [llength $outlines]" + return [::join $outlines \n] + } + + proc ::textblock::trim {block} { + error "textblock::trim unimplemented" + set trimlines "" + } + + #pipealias ::textblock::join_right .= {list $lhs [tcl::string::repeat " " [width $lhs]] $rhs [tcl::string::repeat " " [width $rhs]]} {| + # /2,col1/1,col2/3 + # >} .=> punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| + # >} punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] + set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] + set testblock [textblock::testblock 15 rainbow] + set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] + set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] + } + + + proc example {args} { + set opts [tcl::dict::create -forcecolour 0] + foreach {k v} $args { + switch -- $k { + -forcecolour { + tcl::dict::set opts $k $v + } + default { + error "textblock::example unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]" + } + } + } + set opt_forcecolour 0 + if {[tcl::dict::get $opts -forcecolour]} { + set fc forcecolour + set opt_forcecolour 1 + } else { + set fc "" + } + set pleft [>punk . rhs] + set pright [>punk . lhs] + set prightair [>punk . lhs_air] + set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] + set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] + set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] + set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] + set RST [a] + set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] + set punks [textblock::join -- $pleft $pright] + set pleft_greenb $greenb$pleft$RST + set pright_redb $redb$pright$RST + set prightair_cyanb $cyanb$prightair$RST + set cpunks [textblock::join -- $pleft_greenb $pright_redb] + set out "" + append out $punks \n + append out $cpunks \n + append out [textblock::join -- $punks $cpunks] \n + 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 -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 -- $punkdeck " " $spantable] \n + #append out [textblock::frame -title gr $gr0] + append out [textblock::periodic -forcecolour $opt_forcecolour] + return $out + } + + proc example3 {{text "test\netc\nmore text"}} { + package require patternpunk + .= textblock::join -- [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join -- " " |> .=>1 textblock::join -- $text |> .=>1 textblock::join -- [>punk . rhs] |> .=>1 textblock::join -- [punk::lib::list_as_lines -- [lrepeat 7 " | "]] + } + proc example2 {{text "test\netc\nmore text"}} { + package require patternpunk + .= textblock::join\ + --\ + [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7 8]]\ + [>punk . lhs]\ + " "\ + $text\ + [>punk . rhs]\ + [punk::lib::list_as_lines -- [lrepeat 8 " | "]] + } + proc table {args} { + #todo - use punk::args + upvar ::textblock::class::opts_table_defaults toptdefaults + set defaults [tcl::dict::create\ + -rows [list]\ + -headers [list]\ + -return string\ + ] + + + set defaults [tcl::dict::merge $defaults $toptdefaults] ;# -title -frametype -show_header etc + set opts [tcl::dict::merge $defaults $args] + # -- --- --- --- + set opt_return [tcl::dict::get $opts -return] + set opt_rows [tcl::dict::get $opts -rows] + set opt_headers [tcl::dict::get $opts -headers] + # -- --- --- --- + set topts [tcl::dict::create] + set toptkeys [tcl::dict::keys $toptdefaults] + tcl::dict::for {k v} $opts { + if {$k in $toptkeys} { + tcl::dict::set topts $k $v + } + } + set t [textblock::class::table new {*}$topts] + + foreach h $opt_headers { + $t add_column -headers [list $h] + } + if {[$t column_count] == 0} { + if {[llength $opt_rows]} { + set r0 [lindex $opt_rows 0] + foreach c $r0 { + $t add_column + } + } + } + foreach r $opt_rows { + $t add_row $r + } + + + + if {$opt_return eq "string"} { + set result [$t print] + $t destroy + return $result + } else { + return $t + } + } + + proc frametype {f} { + #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] + switch -- $f { + 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 { + set is_custom_dict_ok 1 + if {[llength $f] %2 == 0} { + #custom dict may leave out keys - but cannot have unknown keys + foreach {k v} $f { + switch -- $k { + all - 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 + break + } + } + } + } else { + set is_custom_dict_ok 0 + } + if {!$is_custom_dict_ok} { + error "frame option -type must be one of known types: $::textblock::frametypes or a dictionary with any of keys all,hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + } + if {[dict exists $f all]} { + return [tcl::dict::create category custom type $f] + } else { + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + set custom_frame [tcl::dict::merge $default_custom $f] + return [tcl::dict::create category custom type $custom_frame] + } + } + } + } + variable framedef_cache [tcl::dict::create] + proc framedef {args} { + #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. + #e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy. + #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. + #the arc set can't even join to itself e.g with curved equivalents of T-like shapes + + #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. + variable framedef_cache + set cache_key $args + if {[tcl::dict::exists $framedef_cache $cache_key]} { + return [tcl::dict::get $framedef_cache $cache_key] + } + + + #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. + #It also means we can't specify checks on the option types etc + set opts [tcl::dict::create\ + -joins ""\ + -boxonly 0\ + ] + set bad_option 0 + 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 $a2 [lindex $args [incr i]] + } + -- { + set values [lrange $args $i+1 end] + break + } + default { + if {[string match -* $a]} { + set bad_option 1 + } else { + set values [lrange $args $i end] + } + break + } + } + } + set f [lindex $values 0] + set rawglobs [lrange $values 1 end] + if {![llength $rawglobs] || "all" in $rawglobs || "*" in $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] { + @id -id ::textblock::framedef + @cmd -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 -optional 1 -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 + } + + set joins [tcl::dict::get $opts -joins] + set boxonly [tcl::dict::get $opts -boxonly] + + + #sorted order down left right up + #1 x choose 4 + #4 x choose 3 + #6 x choose 2 + #4 x choose 1 + #15 combos + + set join_directions [list] + #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode + #e.g down-light, up-heavy + set join_targets [tcl::dict::create left "" down "" right "" up ""] + foreach jt $joins { + lassign [split $jt -] direction target + if {$target ne ""} { + tcl::dict::set join_targets $direction $target + } + lappend join_directions $direction + } + set join_directions [lsort -unique $join_directions] + set do_joins [::join $join_directions _] + + + switch -- $f { + "altg" { + #old style ansi escape sequences with alternate graphics page G0 + set hl [cd::hl] + set hlt $hl + set hlb $hl + set vl [cd::vl] + set vll $vl + set vlr $vl + set tlc [cd::tlc] + set trc [cd::trc] + set blc [cd::blc] + set brc [cd::brc] + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + #No join targets available to join altg to other box styles + switch -- $do_joins { + down { + #1 + set blc [punk::ansi::g0 t] ;#(ltj) + set brc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } left { + #2 + set tlc [punk::ansi::g0 w] ;#(ttj) + set blc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + right { + #3 + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 v] ;#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + up { + #4 + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + } + down_left { + #5 + set blc [punk::ansi::g0 n] ;#(fwj) + set tlc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + down_right { + #6 + set blc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 n] ;#(fwj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_up { + #7 + set blc [punk::ansi::g0 t] ;#(ltj) + set brc [punk::ansi::g0 u] ;#(rtj) + + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set hltj [punk::ansi::g0 v];#(btj) + } + left_right { + #8 + #from 2 + set tlc [punk::ansi::g0 w] ;#(ttj) + set blc [punk::ansi::g0 v] ;#(btj) + #from3 + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + left_up { + #9 + set tlc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 u] ;#(rtj) + set blc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + right_up { + #10 + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 v] ;#(btj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_left_right { + #11 + set blc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 w] ;#(ttj) + set tlc [punk::ansi::g0 w] ;#(ttj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + down_left_up { + #12 + set tlc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 u] ;#(rtj) + set brc [punk::ansi::g0 u] ;#(rtj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + down_right_up { + #13 + set tlc [punk::ansi::g0 t] ;#(ltj) + set blc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + left_right_up { + #14 + set tlc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 v] ;#(btj) + set brc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_left_right_up { + #15 + set tlc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + } + + + } + "ascii" { + 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 $hlt + #set hlbj $hlb + #set vllj $vll + #set vlrj $vlr + #ascii + is small - can reasonably be considered a join to anything? + set hltj + + set hlbj + + set vllj + + set vlrj + + #our corners are all + already - so we won't do anything for directions or targets + + } + "light" { + #unicode box drawing set + set hl [punk::char::charshort boxd_lhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_lv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ldr] + set trc [punk::char::charshort boxd_ldl] + set blc [punk::char::charshort boxd_lur] + set brc [punk::char::charshort boxd_lul] + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #15 combos + #sort order: down left right up + #ltj,rtj,ttj,btj e.g left T junction etc. + #Look at from the perspective of a frame/table outline with a clean border and arms pointing inwards + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'light' + foreach dir {down left right up} { + 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 + } + ascii - altg - arc { + set target$dir light + } + heavy { + set target$dir $target + } + default { + set target$dir other + } + } + } + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + heavy { + set blc [punk::char::charshort boxd_dhrul] ;#\u251f down hieavy and right up light (ltj) + set brc \u2527 ;#boxd_dhlul down heavy and left up light (rtj) + set hlbj \u2530 ;# down heavy (ttj) + } + light { + set blc \u251c ;#[punk::char::charshort boxd_lvr] light vertical and right (ltj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set hlbj \u252c ;# (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + heavy { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + } + light { + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set vllj \u2524 ;# (rtj) + } + } + } + right { + #3 + switch -- $targetright { + heavy { + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + set vlrj \u251d;#right heavy (ltj) + } + light { + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set vlrj \u251c;# (ltj) + } + } + } + up { + #4 + switch -- $targetup { + heavy { + set tlc \u251e ;#up heavy (ltj) + set trc \u2526 ;#up heavy (rtj) + } + light { + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + other-light { + set blc \u2534 ;#(btj) + set tlc \u252c ;#(ttj) + #brc - default corner + set vllj \u2524 ;# (rtj) + } + other-other { + #default corners + } + other-heavy { + set blc \u2535 ;# heavy left (btj) + set tlc \u252d ;#heavy left (ttj) + #brc default corner + set vllj \u2525 ;# heavy left (rtj) + } + heavy-light { + set blc \u2541 ;# heavy down (fwj) + set tlc \u252c ;# light (ttj) + set brc \u2527 ;# heavy down (rtj) + set vllj \u2524 ;# (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + heavy-other { + set blc \u251f ;#heavy down (ltj) + #tlc - default corner + set brc \u2527 ;#heavy down (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + heavy-heavy { + set blc \u2545 ;#heavy down and left (fwj) + set tlc \u252d ;#heavy left (ttj) + set brc \u2527 ;#heavy down (rtj) + set vllj \u2525 ;# heavy left (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + light-light { + set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set tlc \u252c ;# boxd_ldhz (ttj) + set brc \u2524 ;# boxd_lvl light vertical and left(rtj) + set vllj \u2524 ;# (rtj) + set hlbj \u252c ;# (ttj) + } + light-other { + set blc \u251c ;# (ltj) + #tlc - default corner + set brc \u2524 ;# boxd_lvl (rtj) + set hlbj \u252c ;# (ttj) + } + light-heavy { + set blc \u253d ;# heavy left (fwj) + set tlc \u252d ;# heavy left (ttj) + set brc \u2524 ;# light (rtj) + set vllj \u2525 ;# heavy left (rtj) + set hlbj \u252c ;# (ttj) + } + default { + set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set tlc \u252c ;# [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc \u2524 ;# [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + } + } + down_right { + #6 + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + down_up { + #7 + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + left_right { + #8 + #from 2 + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + #from3 + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + + + switch -- $targetleft-$targetright { + heavy-light { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + set vlrj \u251c;#right light (ltj) + } + heavy-other { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + } + heavy-heavy { + set vllj \u2525 ;# left heavy (rtj) + set vlrj \u251d;#right heavy (ltj) + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + } + light-heavy { + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + set vlrj \u251d;#right heavy (ltj) + set vllj \u2524 ;# left light (rtj) + } + light-other { + set vllj \u2524 ;# left light (rtj) + } + light-light { + set vllj \u2524 ;# left light (rtj) + set vlrj \u251c;#right light (ltj) + } + } + #set vllj \u2525 ;# left heavy (rtj) + #set vllj \u2524 ;# left light (rtj) + #set vlrj \u251d;#right heavy (ltj) + #set vlrj \u251c;#right light (ltj) + } + left_up { + #9 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + } + right_up { + #10 + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + } + down_left_right { + #11 + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + + } + down_left_up { + #12 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + + } + down_right_up { + #13 + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + left_right_up { + #14 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + + } + down_left_right_up { + #15 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + } + #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 + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_hv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_hdr] + set trc [punk::char::charshort boxd_hdl] + set blc [punk::char::charshort boxd_hur] + set brc [punk::char::charshort boxd_hul] + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'heavy' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - heavy { + set target$dir heavy + } + light - ascii - altg - arc { + set target$dir light + } + default { + set target$dir other + } + } + } + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + light { + set blc [punk::char::charshort boxd_dlruh] ;#\u2521 down light and right up heavy (ltj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) + set hlbj \u252F ;#down light (ttj) + } + heavy { + set blc [punk::char::charshort boxd_hvr] ;# (ltj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set hlbj \u2533 ;# down heavy (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + light { + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) + set vllj \u2528 ;# left light (rtj) + } + heavy { + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + set vllj \u252b ;#(rtj) + } + } + } + right { + #3 + switch -- $targetright { + light { + set trc [punk::char::charshort boxd_rlldh] ;#\u2531 Right Light and Left Down Heavy (ttj) + set brc [punk::char::charshort boxd_rlluh] ;#\u2539 Right Light and Left Up Heavy(btj) + set vlrj \u2520 ;#right light (ltj) + } + heavy { + set trc [punk::char::charshort boxd_hdhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_huhz] ;# (btj) + set vlrj \u2523 ;# (ltj) + } + } + } + up { + #4 + switch -- $targetup { + light { + set tlc [punk::char::charshort boxd_ulrdh] ;#\u2522 Up Light and Right Down Heavy (ltj) + set trc [punk::char::charshort boxd_ulldh] ;#\u252a Up Light and Left Down Heavy (rtj) + set hltj \u2537 ;# up light (btj) + } + heavy { + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + set hltj \u253b ;# (btj) + } + } + } + down_left { + #down_left is the main join type used for 'L' shaped cell border table building where we boxlimit to {vll hlb blc} + #5 + switch -- down-$targetdown-left-$targetleft { + down-light-left-heavy { + set blc [punk::char::charshort boxd_dluhzh] ;#down light and up horizontal heavy (fwj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) (at tlc down stays heavy) + set hlbj \u252F ;# down light (ttj) + set vllj \u252b ;#(rtj) + } + down-heavy-left-light { + set blc [punk::char::charshort boxd_llrvh] ;# left light and right Vertical Heavy (fwj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) (at brc left must stay heavy) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set hlbj \u2533 ;# down heavy (ttj) + set vllj \u2528 ;# left light (rtj) + } + down-light-left-light { + set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) + set hlbj \u252F ;# down light (ttj) + set vllj \u2528 ;# left light (rtj) + } + down-heavy-left-heavy { + set blc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set hlbj \u2533 ;#(ttj) + set vllj \u252b ;#(rtj) + } + down-other-left-heavy { + set blc \u253b ;#boxd_huhz Heavy Up and Horizontal (btj) + #leave brc default corner + set tlc \u2533 ;#hdhz Heavy Down and Horizontal (ttj) + + set vllj \u252b ;#(rtj) + } + down-other-left-light { + set blc \u253a ;#llruh Left Light and Right Up Heavy (btj) + #leave brc default corner + set tlc \u2532 ;#llrdh Left Light and Right Down Heavy (ttj) + + set vllj \u2528 ;# left light (rtj) + } + down-heavy-left-other { + set blc \u2523 ;#hvr Heavy Vertical and Right (ltj) + set brc \u252b ;#hvl Heavy Veritcal and Left (rtj) + #leave tlc default corner + + set hlbj \u2533 ;#(ttj) + } + down-light-left-other { + set blc \u2521 ;#dlruh Down Light and Right Up Heavy (ltj) + set brc \u2529 ;#dlluh Down Light and Left Up Heavy (rtj) + #leave tlc default corner + + set hlbj \u252F ;# down light (ttj) + } + } + } + down_right { + #6 + set blc [punk::char::charshort boxd_hvr] ;# (ltj) (blc right&up stay heavy) + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) (tlc down&left stay heavy) + set brc [punk::char::charshort boxd_hvhz] ;# (fwj) (brc left&up heavy) + } + down_up { + #7 + set blc [punk::char::charshort boxd_hvr] ;# (ltj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + } + left_right { + #8 + #from 2 + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + #from3 + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) + set brc [punk::char::charshort boxd_huhz] ;# (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) + } + 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) + } + 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) + + } + 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) + + } + 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) + } + 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) + + } + 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) + } + } + } + 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 + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551 + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554 + set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557 + set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A + set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + # \u256c (fwj) + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'double' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - double { + set target$dir double + } + light { + set target$dir light + } + default { + set target$dir other + } + } + } + + #unicode provides no joining for double to anything else + #better to leave a gap by using default double corners if join target is not empty or double + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + double { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + set hlbj \u2566 ;# (ttj) + } + light { + set hlbj \u2564 ;# down light (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + double { + set tlc \u2566 ;# (ttj) + set blc \u2569 ;# (btj) + set vllj \u2563 ;# (rtj) + } + light { + set vllj \u2562 ;# light left (rtj) + } + } + } + right { + #3 + switch -- $targetright { + double { + set trc \u2566 ;# (ttj) + set brc \u2569 ;# (btj) + } + light { + set vlrj \u255F ;# light right (ltj) + } + } + } + up { + #4 + switch -- $targetup { + double { + set tlc \u2560 ;# (ltj) + set trc \u2563 ;# (rtj) + set hltj \u2569 ;# (btj) + } + light { + set hltj \u2567 ;#up light (btj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + double-double { + set blc \u256c ;# (fwj) + set brc \u2563 ;# (rtj) + set tlc \u2566 ;# (ttj) + set hlbj \u2566 ;# (ttj) + } + double-light { + #no corner joins treat corners like 'other' + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + + set hlbj \u2566 ;# (ttj) + set vllj \u2562 ;# light left (rtj) + + } + double-other { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + #leave tlc as ordinary double corner + } + light-double { + + set vllj \u2563 ;# (rtj) + set hlbj \u2564 ;# light down (ttj) + + } + light-light { + + set vllj \u2562 ;# light left (rtj) + set hlbj \u2564 ;# light down (ttj) + } + other-light { + set vllj \u2562 ;# light left (rtj) + } + other-double { + set blc \u2569 ;# (btj) + #leave brc as ordinary double corner + set tlc \u2566 ;# (ttj) + } + } + } + down_right { + #6 + switch -- $targetdown-$targetright { + double-double { + set blc \u2560 ;# (ltj) + set trc \u2566 ;# (ttj) + set brc \u256c ;# (fwj) + set hlbj \u2566 ;# (ttj) + } + double-other { + set blc \u2560 ;# (ltj) + #leave trc default + set brc \u2563 ;# (rtj) + } + other-double { + #leave blc default + set trc \u2566 ;# (ttj) + set brc \u2569 ;#(btj) + } + } + } + down_up { + #7 + switch -- $targetdown-$targetup { + double-double { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + set tlc \u2560 ;# (ltj) + set trc \u2563 ;# (rtj) + set hltj \u2569 ;# (btj) + set hlbj \u2566 ;# (ttj) + } + } + } + left_right { + #8 + + #from 2 + #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_ddhz] ;# (ttj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) + } + left_up { + #9 + 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_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_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_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_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_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_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) + } + } + + } + "arc" { + #unicode box drawing set + + + set hl [punk::char::charshort boxd_lhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_lv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D + set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E + set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 + set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'arc' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - arc { + set target$dir self + } + default { + set target$dir other + } + } + } + + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + self { + set blc \u251c ;# *light (ltj) + #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left + #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable + #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal + + #set brc \u2524 ;# *light(rtj) + #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) + } + } + } + left { + #2 + switch -- $targetleft { + self { + set tlc \u252c ;# *light(ttj) - need a low positioned curved y shape - nothing apparent + #set blc \u2144 ;# (btj) - upside down y - positioning too low for arc + set blc \u2534 ;# *light (btj) + } + } + } + right { + #3 + switch -- $targetright { + self { + set trc \u252c ;# *light (ttj) + #set brc \u2144 ;# (btj) + set brc \u2534 ;# *light (btj) + } + } + } + up { + #4 + switch -- $targetup { + self { + set tlc \u251c ;# *light (ltj) + set trc \u2524 ;# *light(rtj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + self-self { + #set blc \u27e1 ;# white concave-sided diamond - positioned too far right + #set blc \u27e3 ;# concave sided diamond with rightwards tick - positioned too low, too right - big gaps + #set blc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right + set brc \u2524 ;# *light (rtj) + set tlc \u252c ;# *light (ttj) + } + self-other { + #set blc \u2560 ;# (ltj) + #set brc \u2563 ;# (rtj) + #leave tlc as ordinary double corner + } + other-self { + #set blc \u2569 ;# (btj) + #leave brc as ordinary double corner + #set tlc \u2566 ;# (ttj) + } + } + } + down_right { + switch -- $targetdown-$targetright { + self-self { + #set brc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right + set trc \u252c ;# (ttj) + set blc \u2524 ;# (rtj) + } + } + } + } + } + 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 + set hlb \u2594 ;# upper one eighth block + set vll \u258f ;# left one eighth block + set vlr \u2595 ;# right one eighth block + set tlc \u2581 ;# lower one eighth block + set trc \u2581 ;# lower one eighth block + set blc \u2594 ;# upper one eighth block + set brc \u2594 ;# upper one eight block + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + } + block2 { + #the resultant table will have text appear towards top of each box + #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps + set hlt \u2594 ;# upper one eighth block + set hlb \u2581 ;# lower one eighth block + set vlr \u2595 ;# right one eighth block + set vll \u258f ;# left one eighth block + + #some terminals (on windows as at 2024) miscount width of these single-width blocks internally + #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) + #This was fixed in windows-terminal based systems (2021) but persists in others. + #https://github.com/microsoft/terminal/issues/11694 + set tlc \U1fb7d ;#legacy block + set trc \U1fb7e ;#legacy block + set blc \U1fb7c ;#legacy block + set brc \U1fb7f ;#legacy block + + if {[punk::console::check::has_bug_legacysymbolwidth]} { + #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems + set sp \u00a0 ;#non breaking space (plain space may act transparent in some use cases) + set tlc $sp + set trc $sp + set blc $sp + set brc $sp + } + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + } + block2hack { + #the resultant table will have text appear towards top of each box + #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps + set hlt \u2594 ;# upper one eighth block + set hlb \u2581 ;# lower one eighth block + set vlr \u2595 ;# right one eighth block + set vll \u258f ;# left one eighth block + + #see comments in block2 regarding the problems in some terminals that this *may* hack around to some extent. + #the caller probably only needs block2hack if block2 doesn't work + + #1) + #review - this hack looks sort of promising - but overtype::renderline needs fixing ? + #set tlc \U1fb7d\b ;#legacy block + #set trc \U1fb7e\b ;#legacy block + #set blc \U1fb7c\b ;#legacy block + #set brc \U1fb7f\b ;#legacy block + + #2) - works on cmd.exe and some others + # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones + #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) + #this hack has a reasonable chance of working + #except that the punk overtype library does recognise PMs + #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! + #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. + set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block + set trc \U1fb7e\x1b^\b\x1b\\ ;#legacy block + set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block + set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + } + block { + set hlt \u2580 ;#upper half + set hlb \u2584 ;#lower half + set vll \u258c ;#left half + set vlr \u2590 ;#right half + + set tlc \u259b ;#upper left corner half + set trc \u259c + set blc \u2599 + set brc \u259f + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + } + default { + #set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + if {"all" in [dict keys $f]} { + set A [dict get $f all] + set default_custom [tcl::dict::create hl $A vl $A tlc $A trc $A blc $A brc $A] + } + if {[llength $f] % 2} { + #todo - retrieve usage from punk::args + error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $::textblock::frametypes and does not appear to be a dictionary for a custom frametype" + } + #unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults + dict for {k v} $f { + switch -- $k { + all - hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} + default { + error "textblock::frametype '$f' has unknown element '$k'" + } + } + } + #verified keys - safe to extract as vars + set custom_frame [tcl::dict::merge $default_custom $f] + tcl::dict::with custom_frame {} ;#extract keys as vars + #longer j vars must be after their more specific counterparts in the list being processed by foreach + foreach t {hlt hlb vll vlr hltj hlbj vllj vlrj} { + if {[tcl::dict::exists $custom_frame $t]} { + set $t [tcl::dict::get $custom_frame $t] + } else { + #set more explicit type to it's more general counterpart if it's missing + #e.g hlt -> hl + #e.g hltj -> hlt + set $t [set [string range $t 0 end-1]] + } + } + #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set + #horizontal and vertical bar joins - key/variable ends with 'j' + } + } + if {$boxonly} { + set result [tcl::dict::create\ + tlc $tlc hlt $hlt trc $trc\ + vll $vll vlr $vlr\ + blc $blc hlb $hlb brc $brc\ + ] + } else { + set result [tcl::dict::create\ + tlc $tlc hlt $hlt trc $trc\ + vll $vll vlr $vlr\ + blc $blc hlb $hlb brc $brc\ + hltj $hltj\ + hlbj $hlbj\ + vllj $vllj\ + vlrj $vlrj\ + ] + } + 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] + + punk::args::define { + @id -id ::textblock::frame_cache + @cmd -name textblock::frame_cache -help\ + "Display or clear the frame cache." + -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 + } + proc frame_cache {args} { + set argd [punk::args::get_by_id ::textblock::frame_cache $args] + set action [dict get $argd opts -action] + + if {$action ni [list clear ""]} { + error "frame_cache action '$action' not understood. Valid actions: clear" + } + variable frame_cache + if {[dict get $argd opts -pretty]} { + set out [pdict -chan none frame_cache */*] + } else { + set out "" + if {[catch { + set termwidth [tcl::dict::get [punk::console::get_size] columns] + }]} { + set termwidth 80 + } + + tcl::dict::for {k v} $frame_cache { + lassign $v _f frame _used used + set fwidth [textblock::widthtopline $frame] + #review - are cached frames uniform width lines? + #set fwidth [textblock::width $frame] + set frameinfo "$k used:$used " + set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] + if {$allinone_width >= $termwidth} { + #split across 2 lines + append out "$frameinfo\n" + append out $frame \n + } else { + append out [textblock::join -- $frameinfo $frame]\n + } + append out \n ;# frames used to build tables often have joins - keep a line in between for clarity + } + } + if {$action eq "clear"} { + set frame_cache [tcl::dict::create] + append out \nCLEARED + } + return $out + } + + + variable FRAMETYPES + set FRAMETYPES [textblock::frametypes] + variable EG + set EG [a+ brightblack] + variable RST + set RST [a] + + proc frame_samples {} { + set FRAMETYPELABELS [dict create] + if {[info commands ::textblock::frame] ne ""} { + foreach ft [frametypes] { + dict set FRAMETYPELABELS $ft [textblock::frame -checkargs 0 -type $ft " "] + } + } + set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] + return $FRAMETYPELABELS + } + #proc EG {} "return {[a+ brightblack]}" + #make EG fetch from SGR cache so as to abide by colour off/on + proc EG {} { + a+ brightblack + } + #proc RST {} "return {\x1b\[m}" + proc RST {} { + return "\x1b\[m" + } + + #catch 22 for -choicelabels - need some sort of lazy evaluation + # ${[textblock::frame_samples]} + + #todo punk::args alias for centre center etc? + punk::args::define -dynamic 1 { + @id -id ::textblock::frame + @cmd -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 {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ + -choicelabels { + ${[textblock::frame_samples]} + }\ + -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. + ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::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. + ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${[textblock::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. + ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::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. + ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" + } + + #options before content argument - which is allowed to be absent + #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. + # + #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) + # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? + #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand + #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it + # - but we would need to maintain support for the rendered-string based operations too. + proc frame {args} { + variable frametypes + variable use_hash + + #counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var + set opts [tcl::dict::create\ + -etabs 0\ + -type light\ + -boxlimits [list hl vl tlc blc trc brc]\ + -boxmap {}\ + -joins [list]\ + -title ""\ + -subtitle ""\ + -width ""\ + -height ""\ + -ansiborder ""\ + -ansibase ""\ + -blockalign "centre"\ + -textalign "left"\ + -ellipsis 1\ + -usecache 1\ + -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 has_contents 0 + set optlist $args ;#initial only - content will be removed + #no solo opts for frame + if {[llength $args] %2 == 0} { + if {[lindex $args end-1] eq "--"} { + set contents [lpop optlist end] + set has_contents 1 + lpop optlist end ;#drop the end-of-opts flag + } else { + set optlist $args + set contents "" + } + } else { + set contents [lpop optlist 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} $optlist { + 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 + - -checkargs { + tcl::dict::set opts $k2 $v + } + default { + #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 + #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame + if {[llength $args] != 1 && (!$opts_ok || $check_args)} { + set argd [punk::args::get_by_id ::textblock::frame $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_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 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 opt_textalign [tcl::dict::get $opts -textalign] + + 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 + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + + lassign [textblock::frametype $opt_type] _cat category _type ftype + if {$category eq "custom"} { + set custom_frame $ftype + set frameset "custom" + set framedef $custom_frame + } else { + #category = predefined + set frameset $ftype ;# light,heavy etc + set framedef $ftype + } + + #if check_args? + + + #REVIEW - now done in framedef? + #set join_directions [list] + ##targets - light,heavy (double?) - seem to be some required glyphs missing from unicode + ##e.g down-light, up-heavy + #set join_targets [tcl::dict::create left "" down "" right "" up ""] + #foreach jt $opt_joins { + # lassign [split $jt -] direction target + # if {$target ne ""} { + # tcl::dict::set join_targets $direction $target + # } + # lappend join_directions $direction + #} + #set join_directions [lsort -unique $join_directions] + #set do_joins [::join $join_directions _] + + + + + # -- --- --- --- --- --- + + if {$has_contents} { + if {[tcl::string::last \t $contents] >= 0} { + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + if {$opt_etabs} { + #todo + set contents [textutil::tabify::untabify2 $contents $tw] + } + } + set contents [tcl::string::map {\r\n \n} $contents] + if {$opt_crm_mode} { + if {$opt_height eq ""} { + set h [textblock::height $contents] + } else { + set h [expr {$opt_height -2}] + } + if {$opt_width eq ""} { + set w [textblock::width $contents] + } else { + 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 + } + } else { + set actual_contentwidth 0 + set actual_contentheight 0 + } + + if {$opt_title ne ""} { + set titlewidth [punk::ansi::printing_length $opt_title] + set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}] + } else { + set titlewith 0 + set content_or_title_width $actual_contentwidth + } + #opt_subtitle ?? + + if {$opt_width eq ""} { + set frame_inner_width $content_or_title_width + } else { + set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default + } + + if {$opt_height eq ""} { + set frame_inner_height $actual_contentheight + } else { + set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default + } + if {$frame_inner_height == 0 && $frame_inner_width == 0} { + set has_contents 0 + } + #todo - render it with vertical overflow so we can process ansi moves? + #set linecount [textblock::height $contents] + set linecount $frame_inner_height + + # -- --- --- --- --- --- --- --- --- + variable frame_cache + #review - custom frame affects frame_inner_width - exclude from caching? + #set cache_key [concat $optlist $frame_inner_width $frame_inner_height] + #jmn + #set hashables [concat $optlist $frame_inner_width $frame_inner_height] + set hashables [list {*}$optlist $frame_inner_width $frame_inner_height] + + + switch -- $use_hash { + sha1 { + package require sha1 + set hash [sha1::sha1 [encoding convertto utf-8 $hashables]] + } + md5 { + package require md5 + if {[package vsatisfies [package present md5] 2- ] } { + set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review + } else { + set hash [md5::md5 [encoding convertto utf-8 $hashables]] + } + } + none { + set hash $hashables + } + } + + set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth" + #should be in a unicode private range different to that used in table construction + #e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts + #also supplementary private use blocks + #however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult) + #U+F0000 -> U+FFFD + #U+100000 -> U+10FFFD + #FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy) + #should be something someone is unlikely to use as part of a custom frame character. + #ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better) + #As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string + #terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like. + #e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never" + #review - we could consider wasting a few cycles to check for a conflict and use a different FSUB + set FSUB \uF2DD + + + #this occurs commonly in table building with colspans - review + if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { + set usecache 0 + #set buildcache 0 ;#comment out for debug/analysis so we can see + #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" + set cache_key [a+ Web-red web-white]$cache_key[a] + } + if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { + #colourise cache_key to warn + if {$actual_contentwidth == 0} { + #we can still substitute with right length + set cache_key [a+ Web-steelblue web-black]$cache_key[a] + } else { + #actual_contentwidth is narrower than frame - check template's patternwidth + if {[tcl::dict::exists $frame_cache $cache_key]} { + set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] + } else { + set cache_patternwidth $actual_contentwidth + } + if {$actual_contentwidth < $cache_patternwidth} { + set usecache 0 + set cache_key [a+ Web-orange web-black]$cache_key[a] + } elseif {$actual_contentwidth == $cache_patternwidth} { + #set usecache 1 + } else { + #actual_contentwidth > pattern + set usecache 0 + set cache_key [a+ Web-red web-black]$cache_key[a] + } + } + } + + #JMN debug + #set usecache 0 + + set is_cached 0 + if {$usecache && [tcl::dict::exists $frame_cache $cache_key]} { + set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] + set template [tcl::dict::get $frame_cache $cache_key frame] + set used [tcl::dict::get $frame_cache $cache_key used] + tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record + set is_cached 1 + } + + + # -- --- --- --- --- --- --- --- --- + if {!$is_cached} { + # -- --- --- --- --- + # -- --- --- --- --- + set is_joins_ok 1 + foreach v $opt_joins { + lassign [split $v -] direction target + switch -- $direction { + left - right - up - down {} + default { + set is_joins_ok 0 + break + } + } + switch -- $target { + "" - 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 + } + } + } + if {!$is_joins_ok} { + 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 + 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 + } + } + } + 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,hltj,hlbj,vllj,vlrj" + } + # -- --- --- --- --- --- + #these are all valid commands for overtype:: + switch -- $opt_textalign { + left - right - centre - center {} + default { + error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" + } + } + # -- --- --- --- --- --- + switch -- $opt_blockalign { + left - right - centre - center {} + default { + error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign" + } + } + # -- --- --- --- --- + # -- --- --- --- --- + set is_boxlimits_ok 1 + set exact_boxlimits [list] + foreach v $opt_boxlimits { + switch -- $v { + hl { + lappend exact_boxlimits hlt hlb + } + vl { + lappend exact_boxlimits vll vlr + } + hlt - hlb - vll - vlr - tlc - trc - blc - brc { + lappend exact_boxlimits $v + } + default { + #k not in custom_keys + set is_boxlimits_ok 0 + break + } + } + } + #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" + } + set exact_boxlimits [lsort -unique $exact_boxlimits] + # -- --- --- --- --- --- + + + set rst [a] + #set column [tcl::string::repeat " " $frame_inner_width] ;#default - may need to override for custom frame + set underlayline [tcl::string::repeat " " $frame_inner_width] + set underlay [::join [lrepeat $linecount $underlayline] \n] + + + set vll_width 1 ;#default for all except custom (printing width) + set vlr_width 1 + + set framedef [textblock::framedef -joins $opt_joins $framedef] + tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars + + #puts "---> $opt_boxmap" + #review - we handle double-wide in custom frames - what about for boxmaps? + tcl::dict::for {boxelement sub} $opt_boxmap { + if {$boxelement eq "vl"} { + set vll $sub + set vlr $sub + set hl $sub + } elseif {$boxelement eq "hl"} { + set hlt $sub + set hlb $sub + set hl $sub + } else { + set $boxelement $sub + } + } + + switch -- $frameset { + custom { + #REVIEW - textblock::table assumes that at least the vl elements are 1-wide + #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though + #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely + set vll_width [punk::ansi::printing_length $vll] + set hlb_width [punk::ansi::printing_length $hlb] + set hlt_width [punk::ansi::printing_length $hlt] + + set vlr_width [punk::ansi::printing_length $vlr] + + set tlc_width [punk::ansi::printing_length $tlc] + set trc_width [punk::ansi::printing_length $trc] + set blc_width [punk::ansi::printing_length $blc] + set brc_width [punk::ansi::printing_length $brc] + + + set framewidth [expr {$frame_inner_width + 2}] ;#reverse default assumption + if {$opt_width eq ""} { + #width wasn't specified - so user is expecting frame to adapt to title/contents + #content shouldn't truncate because of extra wide frame + #review - punk::console::get_size ? wrapping? quite hard to support with colspans + set frame_inner_width $content_or_title_width + set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width + set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] + } else { + set frame_inner_width [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated + set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}] + set bbarwidth [expr {$opt_width - $blc_width - $brc_width}] + } + #set column [tcl::string::repeat " " $frame_inner_width] + set underlayline [tcl::string::repeat " " $frame_inner_width] + set underlay [::join [lrepeat $linecount $underlayline] \n] + #cache? + + if {$hlt_width == 1} { + set tbar [tcl::string::repeat $hlt $tbarwidth] + } else { + #possibly mixed width chars that make up hlt - tcl::string::range won't get width right + set blank [tcl::string::repeat " " $tbarwidth] + if {$hlt_width > 0} { + set count [expr {($tbarwidth / $hlt_width) + 1}] + } else { + set count 0 + } + set tbar [tcl::string::repeat $hlt $count] + #set tbar [tcl::string::range $tbar 0 $tbarwidth-1] + set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character + } + if {$hlb_width == 1} { + set bbar [tcl::string::repeat $hlb $bbarwidth] + } else { + set blank [tcl::string::repeat " " $bbarwidth] + if {$hlb_width > 0} { + set count [expr {($bbarwidth / $hlb_width) + 1}] + } else { + set count 0 + } + set bbar [tcl::string::repeat $hlb $count] + #set bbar [tcl::string::range $bbar 0 $bbarwidth-1] + set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] + } + } + altg { + set tbar [tcl::string::repeat $hlt $frame_inner_width] + set tbar [cd::groptim $tbar] + set bbar [tcl::string::repeat $hlb $frame_inner_width] + set bbar [cd::groptim $bbar] + } + default { + set tbar [tcl::string::repeat $hlt $frame_inner_width] + set bbar [tcl::string::repeat $hlb $frame_inner_width] + + } + } + + set leftborder 0 + set rightborder 0 + set topborder 0 + set bottomborder 0 + # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + #puts "----->$exact_boxlimits" + foreach lim $exact_boxlimits { + switch -- $lim { + hlt { + set topborder 1 + } + hlb { + set bottomborder 1 + } + vll { + set leftborder 1 + } + vlr { + set rightborder 1 + } + tlc { + set topborder 1 + set leftborder 1 + } + trc { + set topborder 1 + set rightborder 1 + } + blc { + set bottomborder 1 + set leftborder 1 + } + brc { + set bottomborder 1 + set rightborder 1 + } + } + } + if {$opt_width ne "" && $opt_width < 2} { + set rightborder 0 + } + #keep lhs/rhs separate? can we do vertical text on sidebars? + set lhs [tcl::string::repeat $vll\n $linecount] + set lhs [tcl::string::range $lhs 0 end-1] + set rhs [tcl::string::repeat $vlr\n $linecount] + set rhs [tcl::string::range $rhs 0 end-1] + + + if {$opt_ansiborder ne ""} { + set tbar $opt_ansiborder$tbar$rst + set bbar $opt_ansiborder$bbar$rst + set tlc $opt_ansiborder$tlc$rst + set trc $opt_ansiborder$trc$rst + set blc $opt_ansiborder$blc$rst + set brc $opt_ansiborder$brc$rst + + set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out + set rhs $opt_ansiborder$rhs$rst + } + + #boxlimits used for partial borders in table generation + set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] + set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] + foreach lim $unspecified_limits { + switch -- $lim { + vll { + set blank_vll [tcl::string::repeat " " $vll_width] + set lhs [tcl::string::repeat $blank_vll\n $linecount] + set lhs [tcl::string::range $lhs 0 end-1] + } + vlr { + set blank_vlr [tcl::string::repeat " " $vlr_width] + set rhs [tcl::string::repeat $blank_vlr\n $linecount] + set rhs [tcl::string::range $rhs 0 end-1] + } + hlt { + set bar_width [punk::ansi::printing_length $tbar] + set tbar [tcl::string::repeat " " $bar_width] + } + tlc { + set tlc_width [punk::ansi::printing_length $tlc] + set tlc [tcl::string::repeat " " $tlc_width] + } + trc { + set trc_width [punk::ansi::printing_length $trc] + set trc [tcl::string::repeat " " $trc_width] + } + hlb { + set bar_width [punk::ansi::printing_length $bbar] + set bbar [tcl::string::repeat " " $bar_width] + } + blc { + set blc_width [punk::ansi::printing_length $blc] + set blc [tcl::string::repeat " " $blc_width] + } + brc { + set brc_width [punk::ansi::printing_length $brc] + set brc [tcl::string::repeat " " $brc_width] + } + } + } + + if {$opt_title ne ""} { + set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off + } else { + set topbar $tbar + } + if {$opt_subtitle ne ""} { + set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off + } else { + set bottombar $bbar + } + if {$opt_ansibase eq ""} { + set rstbase [a] + } else { + set rstbase [a]$opt_ansibase + } + + if {$opt_title ne ""} { + #title overrides -boxlimits for topborder + set topborder 1 + } + set fs "" + set fscached "" + set cache_patternwidth 0 + #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? + if {$topborder} { + if {$leftborder && $rightborder} { + append fs $tlc$topbar$trc + } else { + if {$leftborder} { + append fs $tlc$topbar + } elseif {$rightborder} { + append fs $topbar$trc + } else { + append fs $topbar + } + } + } + append fscached $fs + if {$has_contents || $opt_height > 2} { + #if {$topborder && $fs ne "xx"} { + # append fs \n + #} + if {$topborder} { + append fs \n + append fscached \n + } + switch -- $opt_textalign { + right {set pad "left"} + left {set pad "right"} + default {set pad $opt_textalign} + } + #set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1] + #set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents] + + set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth] + set cache_patternwidth $actual_contentwidth + set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] + set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] + #after overtype::block - our actual patternwidth may be less + set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] + + if {$leftborder && $rightborder} { + #set bodyparts [list $lhs $inner $rhs] + set cache_bodyparts [list $lhs $cache_inner $rhs] + } else { + if {$leftborder} { + #set bodyparts [list $lhs $inner] + set cache_bodyparts [list $lhs $cache_inner] + } elseif {$rightborder} { + #set bodyparts [list $inner $rhs] + set cache_bodyparts [list $cache_inner $rhs] + } else { + #set bodyparts [list $inner] + set cache_bodyparts [list $cache_inner] + } + } + #set body [textblock::join -- {*}$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 + } + + if {$opt_height eq "" || $opt_height > 1} { + if {$opt_subtitle ne ""} { + #subtitle overrides boxlimits for bottomborder + set bottomborder 1 + } + if {$bottomborder} { + if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { + #append fs \n + append fscached \n + } + if {$leftborder && $rightborder} { + #append fs $blc$bottombar$brc + append fscached $blc$bottombar$brc + } else { + if {$leftborder} { + #append fs $blc$bottombar + append fscached $blc$bottombar + } elseif {$rightborder} { + #append fs $bottombar$brc + append fscached $bottombar$brc + } else { + #append fs $bottombar + append fscached $bottombar + } + } + } + } + set template $fscached + ;#end !$is_cached + } + + + + + #use the same mechanism to build the final frame - whether from cache or template + if {$actual_contentwidth == 0} { + set fs [tcl::string::map [list $FSUB " "] $template] + } else { + set resultlines [list] + set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] + set contentindex 0 + switch -- $opt_textalign { + left {set pad right} + right {set pad left} + default {set pad $opt_textalign} + } + + #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] ""] ;# should not affect actual_contentwidth + } + + #set cwidth [textblock::width $contents] + set cwidth $actual_contentwidth + if {$opt_pad} { + 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} { + set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] + } + #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 { + if {$cwidth > $cache_patternwidth} { + set contents [overtype::renderspace -width $cache_patternwidth "" $contents] + } + set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line + } + + set tlines [split $template \n] + + #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. + #after textblock::join the reset will be a separate code ie should be exactly ESC[0m + set R [a] + set rlen [tcl::string::length $R] + set clines [split $contentblock \n] + + foreach tline $tlines { + if {[tcl::string::first $FSUB $tline] >= 0} { + set content_line [lindex $clines $contentindex] + if {[tcl::string::first $R [string range $content_line 0 10]] == 0} { + set content_line [tcl::string::range $content_line $rlen end] + } + #make sure to replay opt_ansibase to the right of the replacement + lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline] + incr contentindex + } else { + lappend resultlines $tline + } + } + set fs [::join $resultlines \n] + } + + + if {$is_cached} { + return $fs + } else { + if {$buildcache} { + tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] + } + return $fs + } + } + punk::args::define { + @id -id ::textblock::gcross + -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block + Only cross sizes that divide the size of the overall block will be used. + e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. + Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) + If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. + " + @values -min 0 -max 1 + size -default 1 -type integer + } + proc gcross {args} { + set argd [punk::args::get_by_id ::textblock::gcross $args] + set size [dict get $argd values size] + set opts [dict get $argd opts] + + if {$size == 0} { + return "" + } + + set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] + + #set fit_size [punk::lib::greatestOddFactor $size] + set fit_size $size + if {$opt_max_cross_size == 0} { + set max_cross_size $fit_size + } else { + #todo - only allow divisors + #set testsize [expr {min($fit_size,$opt_max_cross_size)}] + + set factors [punk::lib::factors $size] + #pick odd size in list that is smaller or equal to test_size + set max_cross_size [lindex $factors end] + set last_ok [lindex $factors 0] + for {set i 0} {$i < [llength $factors]} {incr i} { + set s [lindex $factors $i] + if {$s > $opt_max_cross_size} { + break + } + set last_ok $s + } + set max_cross_size $last_ok + } + set crosscount [expr {$size / $max_cross_size}] + + package require punk::char + set x [punk::char::charshort boxd_ldc] + set bs [punk::char::charshort boxd_ldgullr] + set fs [punk::char::charshort boxd_ldgurll] + + set onecross "" + set crossrows [list] + set armsize [expr {int(floor($max_cross_size /2))}] + set row [lrepeat $max_cross_size " "] + #toparm + for {set i 0} {$i < $armsize} {incr i} { + set r $row + lset r $i $bs + lset r end-$i $fs + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + + if {$max_cross_size % 2} { + #only put centre cross in for odd sized crosses + set r $row + lset r $armsize $x + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + + for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} { + set r $row + lset r $i $fs + lset r end-$i $bs + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + #set onecross [tcl::string::trimright $onecross \n] + set onecross [::join $crossrows \n] + + #fastest to do row first then columns - because textblock::join must do line by line + + if {$crosscount > 1} { + set row [textblock::join -- {*}[lrepeat $crosscount $onecross]] + set rows [lrepeat $crosscount $row] + set out [::join $rows \n] + } else { + set out $onecross + } + + return $out + } + + #Test we can join two coloured blocks + proc test_colour {} { + set b1 [a red]1\n2\n3[a] + set b2 [a green]a\nb\nc[a] + set result [textblock::join -- $b1 $b2] + puts $result + #return [list $b1 $b2 $result] + return [ansistring VIEW $result] + } + tcl::namespace::import ::punk::ansi::ansistrip +} + + +tcl::namespace::eval ::textblock::piper { + tcl::namespace::export * + proc join {rhs pipelinedata} { + tailcall ::textblock::join -- $pipelinedata $rhs + } +} +interp alias {} piper_blockjoin {} ::textblock::piper::join + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide textblock [tcl::namespace::eval textblock { + variable version + set version 0.1.3 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vendormodules/commandstack-0.3.tm b/src/vendormodules/commandstack-0.3.tm index d7d9813e..ee486569 100644 --- a/src/vendormodules/commandstack-0.3.tm +++ b/src/vendormodules/commandstack-0.3.tm @@ -211,6 +211,7 @@ namespace eval commandstack { set new_code [string trim $procbody] if {$current_code eq $new_code} { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [show_stack $command] } else { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." puts stdout "----------" @@ -223,6 +224,7 @@ namespace eval commandstack { } } else { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" + puts stderr set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid set do_rename 1 } @@ -374,13 +376,13 @@ namespace eval commandstack { proc show_stack {{commandname_glob *}} { variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } if {[package provide punk::lib] ne ""} { return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] } else { - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } set result "" set matchedkeys [dict keys $all_stacks $commandname_glob] #don't try to calculate widest on empty list diff --git a/src/vendormodules/overtype-1.6.5.tm b/src/vendormodules/overtype-1.6.5.tm index 0d9cd0bc..fb044b3c 100644 --- a/src/vendormodules/overtype-1.6.5.tm +++ b/src/vendormodules/overtype-1.6.5.tm @@ -449,7 +449,7 @@ tcl::namespace::eval overtype { 4 { set inputchunks [list] foreach ln [split $overblock \n] { - lappend inputchunks [string cat $ln \n] + lappend inputchunks $ln\n } if {[llength $inputchunks]} { lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] @@ -499,9 +499,9 @@ tcl::namespace::eval overtype { #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set overtext $replay_codes_overlay$overtext if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::string::cat [tcl::dict::get $replay_codes_underlay $row] $undertext] + set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l @@ -1365,8 +1365,8 @@ tcl::namespace::eval overtype { set udiff [expr {$renderwidth - $ulen}] set undertext "$undertext[string repeat { } $udiff]" } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] #review - right-to-left langs should elide on left! - extra option required @@ -1518,8 +1518,8 @@ tcl::namespace::eval overtype { set startoffset 0 ;#negative? } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] if {$overflowlength > 0} { @@ -1545,7 +1545,7 @@ tcl::namespace::eval overtype { } } if {$show_ellipsis} { - set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] + set ellipsis $replay_codes$opt_ellipsistext #todo - overflow on left if allign = right?? set rendered [overtype::right $rendered $ellipsis] } @@ -1701,8 +1701,8 @@ tcl::namespace::eval overtype { set startoffset 0 ;#negative? } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] if {$overflowlength > 0} { @@ -1769,6 +1769,9 @@ tcl::namespace::eval overtype { return [join $outputlines \n] } + + variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. @@ -1802,6 +1805,7 @@ tcl::namespace::eval overtype { #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. #puts stderr "renderline '$args'" + variable optimise_ptruns if {[llength $args] < 2} { error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} @@ -1973,58 +1977,107 @@ tcl::namespace::eval overtype { foreach {pt code} $undermap { #pt = plain text #append pt_underchars $pt - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. - #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. - #todo - test decimal value instead, compare performance - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - set width 1 + if {$pt ne ""} { + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex + set re [tcl::string::cat {^[} \\U$hex {]+$}] + set is_ptrun [regexp $re $pt] + } + if {$is_ptrun} { + #switch -- $p1 { + # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + # set width 1 + # } + # default { + # if {$p1 eq "\u0000"} { + # #use null as empty cell representation - review + # #use of this will probably collide with some application at some point + # #consider an option to set the empty cell character + # set width 1 + # } else { + # set width [grapheme_width_cached $p1] ;# when zero??? + # } + # } + #} + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] + lappend undercols {*}[lrepeat $ptlen $p1] + } else { + incr i_u $ptlen ;#2nd col empty str - so same as above + set 2ptlen [expr {$ptlen * 2}] + lappend understacks {*}[lrepeat $2ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]] + lappend undercols {*}$l + unset l } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] - set grapheme $gvis + + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + set width 1 + } + default { + if {$grapheme eq "\u0000"} { + #use null as empty cell representation - review + #use of this will probably collide with some application at some point + #consider an option to set the empty cell character set width 1 + } else { + #zero width still acts as 1 below??? review what should happen + set width [grapheme_width_cached $grapheme] + #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length + #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI + #todo - default to off and add a flag (?) to enable this substitution + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. + set grapheme $gvis + set width 1 + } + } } } } + + #set width [grapheme_width_cached $grapheme] + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + + lappend undercols $grapheme + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + #but what about emoji combinations etc - can they be wider than 2? + #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + lappend undercols "" + } } - } - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" + } } - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2168,23 +2221,31 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left of the right number of columns. + #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpad_overlay [string repeat " " [expr {$opt_colstart -1}]] - append startpad_overlay $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - if {$startpad_overlay ne ""} { - if {[punk::ansi::ta::detect $startpad_overlay]} { - set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] + set startpadding [string repeat " " [expr {$opt_colstart -1}]] + #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + if {$startpadding ne "" || $overdata ne ""} { + if {[punk::ansi::ta::detect $overdata]} { + set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] } else { #single plaintext part - set overmap [list $startpad_overlay] + set overmap [list $startpadding$overdata] } } else { set overmap [list] } - #set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] #### + + #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) + #will that allow some optimisations? + + #todo - detect repeated transparent char in overlay + #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. + # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data + #we should be able to optimize to pass through the underlay?? + #??? set colcursor $opt_colstart #TODO - make a little virtual column object @@ -2206,41 +2267,78 @@ tcl::namespace::eval overtype { #experiment set overlay_grapheme_control_stacks [list] foreach {pt code} $overmap { - - #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - if {!$crm_mode} { - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack + if {$pt ne ""} { + #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] } - } else { - set tsbegin [clock micros] - foreach grapheme_original [punk::char::grapheme_split $pt] { - set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] - #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" - foreach grapheme [punk::char::grapheme_split $pt_crm] { - if {$grapheme eq "\n"} { + append pt_overchars $pt + #will get empty pt between adjacent codes + if {!$crm_mode} { + + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] + set is_ptrun [regexp $re $pt] + + #leading only? we would have to check for graphemes at the trailing boundary? + #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] + #set is_ptrun [regexp -indices $re $pt runrange] + #if {$is_ptrun && 1} { + #} + } + if {$is_ptrun} { + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) + set len [string length $pt] + set g_element [list g $p1] + + #lappend overstacks {*}[lrepeat $len $o_codestack] + #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] + #incr i_o $len + #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] + #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] + + set pi 0 + incr i_o $len + while {$pi < $len} { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + lappend overlay_grapheme_control_list $g_element lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] - } else { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack + incr pi + } + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_list [list g $grapheme] lappend overlay_grapheme_control_stacks $o_codestack } } + } else { + set tsbegin [clock micros] + foreach grapheme_original [punk::char::grapheme_split $pt] { + set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" + foreach grapheme [punk::char::grapheme_split $pt_crm] { + if {$grapheme eq "\n"} { + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] + } else { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } - set elapsed [expr {[clock micros] - $tsbegin}] - puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2324,6 +2422,7 @@ tcl::namespace::eval overtype { set o_codestack [list $temp_cursor_saved] lappend overlay_grapheme_control_list [list other $code] } else { + #review if {[punk::ansi::codetype::is_gx_open $code]} { set o_gxstack [list "gx0_on"] lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets @@ -2837,7 +2936,8 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] } 7CSI - 7OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + set codenorm $leadernorm[tcl::string::range $code 2 end] } 7DCS { #ESC P @@ -2849,7 +2949,8 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] } 7ESC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + set codenorm $leadernorm[tcl::string::range $code 1 end] } 8CSI - 8OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] @@ -2886,7 +2987,12 @@ tcl::namespace::eval overtype { A { #Row move - up set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set num $param + #todo + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} incr cursor_row -$num @@ -2904,9 +3010,12 @@ tcl::namespace::eval overtype { B { #CUD - Cursor Down #Row move - down - set num $param + lassign [split $param {;}] num modifierkey set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #move down + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} incr cursor_row $num @@ -2924,7 +3033,10 @@ tcl::namespace::eval overtype { #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. #cursor forward #right-arrow/move forward - set num $param + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} #todo - retrict to moving 1 position past datalen? restrict to column width? @@ -3028,7 +3140,10 @@ tcl::namespace::eval overtype { #puts stdout "<-back" #cursor back #left-arrow/move-back when ltr mode - set num $param + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} set version 2 @@ -4518,7 +4633,7 @@ tcl::namespace::eval overtype::priv { if {$existing eq "\0"} { lset o $i $c } else { - lset o $i [string cat $existing $c] + lset o $i $existing$c } } #is actually addgrapheme? 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 367f0a68..16387b0a 100644 --- a/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm @@ -296,7 +296,7 @@ namespace eval argparsingtest { return [tcl::dict::get $argd opts] } - punk::args::definition { + punk::args::define { @id -id ::test1_punkargs_by_id @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @opts -anyopts 0 @@ -318,7 +318,7 @@ namespace eval argparsingtest { return [tcl::dict::get $argd opts] } - punk::args::definition { + punk::args::define { @id -id ::argparsingtest::test1_punkargs2 @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @opts -anyopts 0 diff --git a/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm b/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm index d7d9813e..ee486569 100644 --- a/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm @@ -211,6 +211,7 @@ namespace eval commandstack { set new_code [string trim $procbody] if {$current_code eq $new_code} { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [show_stack $command] } else { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." puts stdout "----------" @@ -223,6 +224,7 @@ namespace eval commandstack { } } else { puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" + puts stderr set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid set do_rename 1 } @@ -374,13 +376,13 @@ namespace eval commandstack { proc show_stack {{commandname_glob *}} { variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } if {[package provide punk::lib] ne ""} { return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] } else { - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } set result "" set matchedkeys [dict keys $all_stacks $commandname_glob] #don't try to calculate widest on empty list 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 0d9cd0bc..fb044b3c 100644 --- a/src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm +++ b/src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm @@ -449,7 +449,7 @@ tcl::namespace::eval overtype { 4 { set inputchunks [list] foreach ln [split $overblock \n] { - lappend inputchunks [string cat $ln \n] + lappend inputchunks $ln\n } if {[llength $inputchunks]} { lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] @@ -499,9 +499,9 @@ tcl::namespace::eval overtype { #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set overtext $replay_codes_overlay$overtext if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::string::cat [tcl::dict::get $replay_codes_underlay $row] $undertext] + set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l @@ -1365,8 +1365,8 @@ tcl::namespace::eval overtype { set udiff [expr {$renderwidth - $ulen}] set undertext "$undertext[string repeat { } $udiff]" } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] #review - right-to-left langs should elide on left! - extra option required @@ -1518,8 +1518,8 @@ tcl::namespace::eval overtype { set startoffset 0 ;#negative? } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] if {$overflowlength > 0} { @@ -1545,7 +1545,7 @@ tcl::namespace::eval overtype { } } if {$show_ellipsis} { - set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] + set ellipsis $replay_codes$opt_ellipsistext #todo - overflow on left if allign = right?? set rendered [overtype::right $rendered $ellipsis] } @@ -1701,8 +1701,8 @@ tcl::namespace::eval overtype { set startoffset 0 ;#negative? } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] if {$overflowlength > 0} { @@ -1769,6 +1769,9 @@ tcl::namespace::eval overtype { return [join $outputlines \n] } + + variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. @@ -1802,6 +1805,7 @@ tcl::namespace::eval overtype { #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. #puts stderr "renderline '$args'" + variable optimise_ptruns if {[llength $args] < 2} { error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} @@ -1973,58 +1977,107 @@ tcl::namespace::eval overtype { foreach {pt code} $undermap { #pt = plain text #append pt_underchars $pt - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. - #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. - #todo - test decimal value instead, compare performance - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - set width 1 + if {$pt ne ""} { + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex + set re [tcl::string::cat {^[} \\U$hex {]+$}] + set is_ptrun [regexp $re $pt] + } + if {$is_ptrun} { + #switch -- $p1 { + # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + # set width 1 + # } + # default { + # if {$p1 eq "\u0000"} { + # #use null as empty cell representation - review + # #use of this will probably collide with some application at some point + # #consider an option to set the empty cell character + # set width 1 + # } else { + # set width [grapheme_width_cached $p1] ;# when zero??? + # } + # } + #} + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] + lappend undercols {*}[lrepeat $ptlen $p1] + } else { + incr i_u $ptlen ;#2nd col empty str - so same as above + set 2ptlen [expr {$ptlen * 2}] + lappend understacks {*}[lrepeat $2ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]] + lappend undercols {*}$l + unset l } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] - set grapheme $gvis + + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + set width 1 + } + default { + if {$grapheme eq "\u0000"} { + #use null as empty cell representation - review + #use of this will probably collide with some application at some point + #consider an option to set the empty cell character set width 1 + } else { + #zero width still acts as 1 below??? review what should happen + set width [grapheme_width_cached $grapheme] + #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length + #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI + #todo - default to off and add a flag (?) to enable this substitution + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. + set grapheme $gvis + set width 1 + } + } } } } + + #set width [grapheme_width_cached $grapheme] + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + + lappend undercols $grapheme + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + #but what about emoji combinations etc - can they be wider than 2? + #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + lappend undercols "" + } } - } - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" + } } - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2168,23 +2221,31 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left of the right number of columns. + #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpad_overlay [string repeat " " [expr {$opt_colstart -1}]] - append startpad_overlay $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - if {$startpad_overlay ne ""} { - if {[punk::ansi::ta::detect $startpad_overlay]} { - set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] + set startpadding [string repeat " " [expr {$opt_colstart -1}]] + #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + if {$startpadding ne "" || $overdata ne ""} { + if {[punk::ansi::ta::detect $overdata]} { + set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] } else { #single plaintext part - set overmap [list $startpad_overlay] + set overmap [list $startpadding$overdata] } } else { set overmap [list] } - #set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] #### + + #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) + #will that allow some optimisations? + + #todo - detect repeated transparent char in overlay + #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. + # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data + #we should be able to optimize to pass through the underlay?? + #??? set colcursor $opt_colstart #TODO - make a little virtual column object @@ -2206,41 +2267,78 @@ tcl::namespace::eval overtype { #experiment set overlay_grapheme_control_stacks [list] foreach {pt code} $overmap { - - #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - if {!$crm_mode} { - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack + if {$pt ne ""} { + #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] } - } else { - set tsbegin [clock micros] - foreach grapheme_original [punk::char::grapheme_split $pt] { - set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] - #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" - foreach grapheme [punk::char::grapheme_split $pt_crm] { - if {$grapheme eq "\n"} { + append pt_overchars $pt + #will get empty pt between adjacent codes + if {!$crm_mode} { + + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] + set is_ptrun [regexp $re $pt] + + #leading only? we would have to check for graphemes at the trailing boundary? + #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] + #set is_ptrun [regexp -indices $re $pt runrange] + #if {$is_ptrun && 1} { + #} + } + if {$is_ptrun} { + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) + set len [string length $pt] + set g_element [list g $p1] + + #lappend overstacks {*}[lrepeat $len $o_codestack] + #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] + #incr i_o $len + #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] + #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] + + set pi 0 + incr i_o $len + while {$pi < $len} { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + lappend overlay_grapheme_control_list $g_element lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] - } else { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack + incr pi + } + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_list [list g $grapheme] lappend overlay_grapheme_control_stacks $o_codestack } } + } else { + set tsbegin [clock micros] + foreach grapheme_original [punk::char::grapheme_split $pt] { + set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" + foreach grapheme [punk::char::grapheme_split $pt_crm] { + if {$grapheme eq "\n"} { + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] + } else { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } - set elapsed [expr {[clock micros] - $tsbegin}] - puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2324,6 +2422,7 @@ tcl::namespace::eval overtype { set o_codestack [list $temp_cursor_saved] lappend overlay_grapheme_control_list [list other $code] } else { + #review if {[punk::ansi::codetype::is_gx_open $code]} { set o_gxstack [list "gx0_on"] lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets @@ -2837,7 +2936,8 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] } 7CSI - 7OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + set codenorm $leadernorm[tcl::string::range $code 2 end] } 7DCS { #ESC P @@ -2849,7 +2949,8 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] } 7ESC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + set codenorm $leadernorm[tcl::string::range $code 1 end] } 8CSI - 8OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] @@ -2886,7 +2987,12 @@ tcl::namespace::eval overtype { A { #Row move - up set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set num $param + #todo + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} incr cursor_row -$num @@ -2904,9 +3010,12 @@ tcl::namespace::eval overtype { B { #CUD - Cursor Down #Row move - down - set num $param + lassign [split $param {;}] num modifierkey set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #move down + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} incr cursor_row $num @@ -2924,7 +3033,10 @@ tcl::namespace::eval overtype { #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. #cursor forward #right-arrow/move forward - set num $param + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} #todo - retrict to moving 1 position past datalen? restrict to column width? @@ -3028,7 +3140,10 @@ tcl::namespace::eval overtype { #puts stdout "<-back" #cursor back #left-arrow/move-back when ltr mode - set num $param + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} set version 2 @@ -4518,7 +4633,7 @@ tcl::namespace::eval overtype::priv { if {$existing eq "\0"} { lset o $i $c } else { - lset o $i [string cat $existing $c] + lset o $i $existing$c } } #is actually addgrapheme? diff --git a/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm b/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm index 4f13a121..6611eee5 100644 --- a/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm @@ -111,7 +111,8 @@ proc TCL {args} { return $version } -punk::args::definition { +punk::args::define { + #Review @id -id ">punk . poses" @cmd -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" 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 5affa204..37117d6d 100644 --- a/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm @@ -198,7 +198,7 @@ tcl::namespace::eval poshinfo { error "unimplemented" } - punk::args::definition { + punk::args::define { @id -id ::poshinfo::themes @cmd -name poshinfo::themes -format -default all -multiple 1 -choices {all yaml json}\ diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm index 1a9ab766..08359461 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm @@ -12,6 +12,242 @@ namespace eval punk { #lazyload twapi ? catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later + + variable can_exec_windowsapp + set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed + variable windowsappdir + set windowsappdir "" + variable cmdexedir + set cmdexedir "" + + proc rehash {{refresh 0}} { + global auto_execs + if {!$refresh} { + unset -nocomplain auto_execs + } else { + set names [array names auto_execs] + unset -nocomplain auto_execs + foreach nm $names { + auto_execok_windows $nm + } + } + return + } + + + proc ::punk::auto_execok_original name [info body ::auto_execok] + variable better_autoexec + + #set better_autoexec 0 ;#use this var via better_autoexec only + #proc ::punk::auto_execok_windows name { + # ::punk::auto_execok_original $name + #} + + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + + set has_commandstack [expr {![catch {package require commandstack}]}] + if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} { + + #still a caching version of auto_execok - but with proper(fixed) search order + + #set b [info body ::auto_execok] + #proc ::auto_execok_original name $b + + proc better_autoexec {{onoff ""}} { + variable better_autoexec + if {$onoff eq ""} { + return $better_autoexec + } + if {![string is boolean -strict $onoff]} { + error "better_autoexec argument 'onoff' must be a boolean, received: $onoff" + } + if {$onoff && ($onoff != $better_autoexec)} { + puts "Turning on better_autoexec - search PATH first then extension" + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + punk::rehash + } elseif {!$onoff && ($onoff != $better_autoexec)} { + puts "Turning off better_autoexec - search extension then PATH" + set better_autoexec 0 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_original $name + } + punk::rehash + } else { + puts "no change" + } + } + #better_autoexec $better_autoexec ;#init to default + + + proc auto_execok_better name { + global auto_execs env tcl_platform + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + #puts stdout "[a+ red]...[a]" + set auto_execs($name) "" + + set shellBuiltins [list assoc cls copy date del dir echo erase exit ftype \ + md mkdir mklink move rd ren rename rmdir start time type ver vol] + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + if {[string tolower $name] in $shellBuiltins} { + # When this is command.com for some reason on Win2K, Tcl won't + # exec it unless the case is right, which this corrects. COMSPEC + # may not point to a real file, so do the check. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext $execExtensions { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + return "" + } + + #change1 + #set path "[file dirname [info nameofexecutable]];.;" + set path "[file dirname [info nameofexecutable]];" + + if {[info exists env(SystemRoot)]} { + set windir $env(SystemRoot) + } elseif {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + append path "$windir/system32;$windir/system;$windir;" + } + + foreach var {PATH Path path} { + if {[info exists env($var)]} { + append path ";$env($var)" + } + } + + #change2 + set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + foreach dir [split $path {;}] { + #set dir [file normalize $dir] + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} + + foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] { + set file [file join $dir $match] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + } + + #foreach ext $execExtensions { + #unset -nocomplain checked + #foreach dir [split $path {;}] { + # # Skip already checked directories + # if {[info exists checked($dir)] || ($dir eq "")} { + # continue + # } + # set checked($dir) {} + # set file [file join $dir ${name}${ext}] + # if {[file exists $file] && ![file isdirectory $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + #} + return "" + } + + + + #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? + #what if we create another interp and use the same ::auto_execs? The appdir won't be detected. + #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed + + + + #winget is installed on all modern windows and is an example of the problem this addresses + #we target apps with same location + + #the main purpose of this override is to support windows app executables (installed as 'reparse points') + #for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac + #versions prior to this will use cmd.exe to resolve the links + set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name { + #set windowsappdir "%appdir%" + upvar ::punk::can_exec_windowsapp can_exec_windowsapp + upvar ::punk::windowsappdir windowsappdir + upvar ::punk::cmdexedir cmdexedir + + if {$windowsappdir eq ""} { + #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' + #Tcl (2025) can't exec when given a path to these 0KB files + #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps + if {!([info exists ::env(LOCALAPPDATA)] && + [file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} { + #should be unlikely to get here - unless LOCALAPPDATA missing + set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]] + puts stderr "(resolved winget by search)" + } else { + set windowsappdir [file dirname $testapp] + } + } + + #set default_auto [$COMMANDSTACKNEXT $name] + set default_auto [::punk::auto_execok_windows $name] + #if {$name ni {cmd cmd.exe}} { + # unset -nocomplain ::auto_execs + #} + + if {$default_auto eq ""} { + return + } + set namedir [file dirname [lindex $default_auto 0]] + + if {$namedir eq $windowsappdir} { + if {$can_exec_windowsapp eq "unknown"} { + if {[catch {exec [file join $windowsappdir winget.exe] --version}]} { + set can_exec_windowsapp 0 + } else { + set can_exec_windowsapp 1 + } + } + if {$can_exec_windowsapp} { + return [file join $windowsappdir $name] + } + if {$cmdexedir eq ""} { + #cmd.exe very unlikely to move + set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] + #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index + #anyway.. it has other side effects (affects auto_load) + } + return "[file join $cmdexedir cmd.exe] /c $name" + } + return $default_auto + }] + + + } + } @@ -5321,8 +5557,8 @@ namespace eval punk { } return -options $opts $msg } else { - dict incr opts -level - return -options $opts $msg + dict incr opts -level + return -options $opts $msg } } } @@ -7152,7 +7388,7 @@ namespace eval punk { dict filter $result value {?*} } - punk::args::definition { + punk::args::define { @id -id ::punk::inspect @cmd -name punk::inspect -help\ "Function to display values - used pimarily in a punk pipeline. 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 c17bacf2..296bb6df 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 @@ -115,6 +115,7 @@ tcl::namespace::eval punk::aliascore { pdict ::punk::lib::pdict\ plist {::punk::lib::pdict -roottype list}\ showlist {::punk::lib::showdict -roottype list}\ + rehash ::punk::rehash\ showdict ::punk::lib::showdict\ ansistrip ::punk::ansi::ansistrip\ stripansi ::punk::ansi::ansistrip\ 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 a3f9c0b5..422c524e 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 @@ -5568,6 +5568,7 @@ tcl::namespace::eval punk::ansi::class { } #does not affect object state + #REVIEW - icu or equiv required method DoCount {plaintext} { #- combiners/diacritics just map them away here - but for consistency we need to combine unicode grapheme clusters too. #todo - joiners 200d? zwnbsp @@ -5672,6 +5673,7 @@ tcl::namespace::eval punk::ansi::class { method renderbuf {} { #get the underlying renderobj - if any #return $o_renderout ;#also class_ansistring + if {$o_renderer eq ""} {error "renderbuf error: no active renderer"} return [$o_renderer renderbuf] } method render {{maxgraphemes ""}} { 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 2c9c77fa..78a18304 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 @@ -247,12 +247,12 @@ tcl::namespace::eval punk::args::register { tcl::namespace::eval punk::args { - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::definition at the end. + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. tcl::namespace::export {[a-z]*} variable argdata_cache variable argdefcache_by_id - variable argdefcache_unresolved + variable argdefcache_unresolved ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) variable id_counter set argdata_cache [tcl::dict::create] set argdefcache_by_id [tcl::dict::create] @@ -282,10 +282,18 @@ tcl::namespace::eval punk::args { set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::definition + @id -id ::punk::args::define #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::definition -help\ + @cmd -name punk::args::define -help\ "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + This can be used purely for documentation or called within a function to parse a mix of leading values, switches/flags and trailing values. @@ -427,10 +435,13 @@ tcl::namespace::eval punk::args { " @values -min 1 -max -1 text -type string -multiple 1 -help\ - "Block(s) of text representing the argument specification for a command. + "Block(s) of text representing the argument definition for a command. At least one must be supplied. If multiple, they are joined together with \\n. Using multiple text arguments may be useful to mix curly-braced and double-quoted strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + e.g the following definition passes 2 blocks as text arguments definition { @id -id ::myns::myfunc @@ -450,22 +461,135 @@ tcl::namespace::eval punk::args { } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" " }]] - proc definition {args} { + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -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_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + proc define {args} { variable argdata_cache variable argdefcache_by_id variable argdefcache_unresolved - #variable initial_optspec_defaults - #variable initial_valspec_defaults + set cache_key $args #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) #review - check if there is a built-into-tcl way to do this quickly #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. - set cache_key $args set textargs $args - + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } set is_dynamic 0 if {[lindex $args 0] eq "-dynamic"} { set is_dynamic [lindex $args 1] @@ -485,6 +609,8 @@ tcl::namespace::eval punk::args { set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] } } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] lassign $pt_params ptlist paramlist @@ -509,6 +635,7 @@ tcl::namespace::eval punk::args { tcl::dict::set argdefcache_unresolved $cache_key $pt_params } } + #argdata_cache should be limited in some fashion or will be a big memory leak??? if {[tcl::dict::exists $argdata_cache $optionspecs]} { #resolved cache version exists return [tcl::dict::get $argdata_cache $optionspecs] @@ -517,46 +644,6 @@ tcl::namespace::eval punk::args { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -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_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] #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 @@ -566,21 +653,14 @@ tcl::namespace::eval punk::args { #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 leader_required [list] set opt_required [list] set val_required [list] - set arg_info [tcl::dict::create] - set arg_checks [tcl::dict::create] set opt_defaults [tcl::dict::create] - set opt_names [list] ;#defined opts - set leader_defaults [tcl::dict::create] set val_defaults [tcl::dict::create] set opt_solos [list] - #first process dashed and non-dashed argspecs without regard to whether non-dashed are at the beginning or end - set leader_names [list] - set val_names [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end set records [list] set linebuild "" @@ -602,7 +682,7 @@ tcl::namespace::eval punk::args { foreach rawline $linelist { set recordsofar [tcl::string::cat $linebuild $rawline] #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in argspecs. + #review - when exactly are ansi codes allowed/expected in record lines. # - we might reasonably expect them in default values or choices or help strings # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. # - eg set line "set x \"a[a+ red]red[a]\"" @@ -656,48 +736,137 @@ tcl::namespace::eval punk::args { set id_info {} ;#e.g -children ?? set doc_info {} set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set parser_info {} - set leader_min "" - #set leader_min 0 - #set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - set leader_max "" + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" #(common case of no leaders specified) set opt_any 0 set val_min 0 set val_max -1 ;#-1 for no limit - set spec_id "" - set argspace "leaders" ;#leaders -> options -> values - set parser_id 0 - foreach ln $records { - set trimln [tcl::string::trim $ln] - switch -- [tcl::string::index $trimln 0] { + set DEF_definition_id "" + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { "" - # {continue} } - set linespecs [lassign $trimln argname] - if {[llength $linespecs] % 2 != 0} { - error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs' id:$spec_id" + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } } - set firstchar [tcl::string::index $argname 0] - set secondchar [tcl::string::index $argname 1] + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] if {$firstchar eq "@" && $secondchar ne "@"} { - set at_specs $linespecs + set record_type "directive" + set directive_name $firstword + set at_specs $record_values - switch -- [tcl::string::range $argname 1 end] { + switch -- [tcl::string::range $directive_name 1 end] { id { #id An id will be allocated if no id line present or the -id value is "auto" - if {$spec_id ne ""} { + if {$DEF_definition_id ne ""} { #disallow duplicate @id line - error "punk::args::definition - @id already set. Existing value $spec_id" + error "punk::args::define - @id already set. Existing value $DEF_definition_id" } if {[dict exists $at_specs -id]} { - set spec_id [dict get $at_specs -id] + set DEF_definition_id [dict get $at_specs -id] } else { - set spec_id auto + set DEF_definition_id auto } set id_info $at_specs } + ref { + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } default { - #copy from an identified set of defaults (another argspec id) can be multiple + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define -dynamic 1 making *immediate* resolutions .. is that really desirable? + if {[dict exists $at_specs -id]} { set copyfrom [get_def [dict get $at_specs -id]] #we don't copy the @id info from the source @@ -711,20 +880,27 @@ tcl::namespace::eval punk::args { if {![dict size $doc_info]} { set doc_info [dict get $copyfrom doc_info] } - if {![dict size $argdisplay_info]} { - set argdisplay_info [dict get $copyfrom argdisplay_info] + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? } - #TODO - #create leaders opts vals depending on position of @default line? - #options on @default line to exclude/include sets??? } } } - parser { + form { + # arity system ? #handle multiple parsing styles based on arities and keyword positions (and/or flags?) #e.g see lseq manual with 3 different parsing styles. #aim to produce a table/subtable for each - # *parser -description "start ?('..'|'to')? end ??'by'? step?"\ + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ # -arities { # 2 # {3 anykeys {1 .. 1 to}} @@ -733,24 +909,36 @@ tcl::namespace::eval punk::args { # }\ # -fallback 1 # ... - # *parser -description "start 'count' count ??'by'? step?"\ + # @parser -synopsis "start 'count' count ??'by'? step?"\ # -arities { # {3 anykeys {1 count}} # } # ... - # *parser -description "count ?'by' step?"\ + # @form -synopsis "count ?'by' step?"\ # -arities { # 1 # {3 anykeys {1 by}} # } # # see also after manual - # *parser -arities {1} - # *parser -arities { + # @form -arities {1} + # @form -arities { # 1 anykeys {0 info} # } #todo - set parser_info $at_specs + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) } cmd { #allow arbitrary - review @@ -765,475 +953,644 @@ tcl::namespace::eval punk::args { set argdisplay_info [dict merge $argdisplay_info $at_specs] } opts { - if {$argspace eq "values"} { - error "punk::args::definition - @opts declaration must come before @values - received '$linespecs' id:$spec_id" - } - set argspace "options" - foreach {k v} $at_specs { - switch -- $k { - -any - - -anyopts { - set opt_any $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset optspec_defaults $k2 + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 } - none - "" - - - any - ansistring - globstring - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" } - tcl::dict::set optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set optspec_defaults $k $v - } - default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @opts line. Known keys: $known id:$spec_id" } } - } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids } leaders { - if {$argspace in [list options values]} { - error "punk::args::definition - @leaders declaration must come before all options and values id:$spec_id" - } - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$spec_id" + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} } - set leader_min $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$spec_id" + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v } - set leader_max $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset leaderspec_defaults $k2 + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" } - tcl::dict::set leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set leaderspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @leaders line. Known keys: $known @id:$spec_id" } } - } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids } values { - set argspace "values" - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$spec_id" - } - set val_min $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$spec_id" - } - set val_max $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegoups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset valspec_defaults $k2 + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" } - bool - boolean { - set v bool + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" } - dict - dictionary { - set v dict + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegoups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 } - list { + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + } + default { + #todo - disallow unknown types unless prefixed with custom- + } } - default { - #todo - disallow unknown types unless prefixed with custom- - } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" } - tcl::dict::set valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::definition - unrecognised key '$k' in @values line. Known keys: $known @id:$spec_id" } } + dict set F $fid valspec_defaults $tmp_valspec_defaults } } default { - error "punk::args::definition - unrecognised @ line in '$ln'. Expected @id @cmd @leaders @opts or @values - use @@name if paramname needs to be @name @id:$spec_id" + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" } } + #record_type directive continue } elseif {$firstchar eq "-"} { - if {$argspace eq "leaders"} { - set argspace "options" - } elseif {$argspace eq "values"} { - error "punk::args::definition - invalid placement of line '$ln' - must come before @values @id:$spec_id" - } - set argspecs $linespecs - tcl::dict::set argspecs -ARGTYPE option - lappend opt_names $argname + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + set is_opt 1 } else { + set argname $firstword if {$firstchar eq "@"} { #allow basic @@ escaping for literal argname that begins with @ set argname [tcl::string::range $argname 1 end] } - set argspecs $linespecs - if {$argspace eq "leaders"} { - tcl::dict::set argspecs -ARGTYPE leader - lappend leader_names $argname - if {$leader_max >= 0} { - set leader_max [llength $leader_names] + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname } - } else { - tcl::dict::set argspecs -ARGTYPE value - lappend val_names $argname } + set is_opt 0 } + + #assert - we only get here if it is a value or flag specification line. - #assert argspecs has been set to the value of linespecs - if {$is_opt} { - set spec_merged $optspec_defaults - } else { - if {$argspace eq "values"} { - set spec_merged $valspec_defaults + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] } else { - set spec_merged $leaderspec_defaults + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } } - } - foreach {spec specval} $argspecs { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { - tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" } - lappend opt_solos $argname - } else { - #-solo only valid for flags - error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname' @id:$spec_id" } - } - 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] + 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 - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$spec_id" + -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$spec_id" + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" } } - } - default { - set known_argspecs [list -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - ] - error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs @id:$spec_id" - } - } - } - set argspecs $spec_merged - if {$is_opt} { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } else { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set arg_info $argname $argspecs - tcl::dict::set arg_checks $argname $argchecks - #review existence of -default overriding -optional - if {![tcl::dict::get $argspecs -optional] && ![tcl::dict::exists $argspecs -default]} { + } ;# end foreach {spec specval} argdef_values + + if {$is_opt} { - lappend opt_required $argname + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } else { - if {$argspace eq "leaders"} { - lappend leader_required $argname + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname } else { - lappend val_required $argname + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } } } - } - if {[tcl::dict::exists $argspecs -default]} { - if {$is_opt} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $argspecs -default] - } else { - if {$argspace eq "leaders"} { - tcl::dict::set leader_defaults $argname [tcl::dict::get $argspecs -default] + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $argspecs -default] + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } } } - } - } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + - if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { + if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { variable id_counter - set spec_id "autoid_[incr id_counter]" - } - - # REVIEW - #if {[llength $val_names] || $val_min > 0} { - # #some values are specified - # foreach leadername [lrange $leader_names 0 end] { - # if {[tcl::dict::get $arg_info $leadername -multiple]} { - # error "bad key -multiple on argument spec for leader '$leadername'. Last leader argument specification can be marked -multiple only when no values are specified" - # } - # } - #} else { + set DEF_definition_id "autoid_[incr id_counter]" + } + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW #no values specified - we can allow last leader to be multiple - foreach leadername [lrange $leader_names 0 end-1] { - if {[tcl::dict::get $arg_info $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple @id:$spec_id" + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" } } - #} - #confirm any valnames before last don't have -multiple key - foreach valname [lrange $val_names 0 end-1] { - if {[tcl::dict::get $arg_info $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple @id:$spec_id" + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - set leader_checks_defaults [tcl::dict::remove $leaderspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } set argdata_dict [tcl::dict::create\ - id $spec_id\ - arg_info $arg_info\ - arg_checks $arg_checks\ - leader_defaults $leader_defaults\ - leader_required $leader_required\ - leader_names $leader_names\ - leader_min $leader_min\ - leader_max $leader_max\ - leaderspec_defaults $leaderspec_defaults\ - leader_checks_defaults $leader_checks_defaults\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - opt_names $opt_names\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults $optspec_defaults\ - opt_checks_defaults $opt_checks_defaults\ - val_defaults $val_defaults\ - val_required $val_required\ - val_names $val_names\ - val_min $val_min\ - val_max $val_max\ - valspec_defaults $valspec_defaults\ - val_checks_defaults $val_checks_defaults\ - cmd_info $cmd_info\ - doc_info $doc_info\ - argdisplay_info $argdisplay_info\ - id_info $id_info\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + argdisplay_info $argdisplay_info\ + id_info $id_info\ + temp_F $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ ] + tcl::dict::set argdata_cache $cache_key $argdata_dict if {$is_dynamic} { #also cache resolved version tcl::dict::set argdata_cache $optionspecs $argdata_dict } - #tcl::dict::set argdefcache_by_id $spec_id $optionspecs - tcl::dict::set argdefcache_by_id $spec_id $args + #tcl::dict::set argdefcache_by_id $DEF_definition_id $optionspecs + tcl::dict::set argdefcache_by_id $DEF_definition_id $args #puts "xxx:$result" return $argdata_dict } - proc get_spec {id {patternlist *}} { + lappend PUNKARGS [list -dynamic 0 { + @id -id ::punk::args::get_spec + @cmd -name punk::args::get_definition -help\ + "" + id -type string -help\ + "identifer for punk::args defintion + This will usually be a fully-qualifed + path for a command name" + patternlist -type list -optional 1 -default * -help\ + "glob-style patterns for retrieving value or switch + definitions. If ommitted or passed an empty string, + the raw unresolved definition will be returned as + a list, including possible leading flags such as + -dynamic 0|1. + If specified as * - the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + " + override_dict -type dict -optional 1 -default "" -help\ + "unimplemented. + Will allow overriding or adding flags to a returned + definition line. + " + }] + #rename get_definition ??? + proc get_spec {id args} { + lassign $args patternlist override_dict + if {[llength $args] > 2} { + punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args] + return + } + if {[llength $override_dict] % 2 != 0} { + #malformed dict + punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args] + return + } + variable argdefcache_by_id set realid [real_id $id] if {$realid ne ""} { - if {$patternlist eq "*"} { - #todo? + if {$patternlist eq ""} { + #return the raw definition - possibly with unresolved dynamic parts return [tcl::dict::get $argdefcache_by_id $realid] } else { - set speclist [tcl::dict::get $argdefcache_by_id $realid] + set deflist [tcl::dict::get $argdefcache_by_id $realid] set result "" - set specdict [uplevel 1 [list ::punk::args::definition {*}$speclist]] - set arg_info [dict get $specdict arg_info] + set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]] + set arg_info [dict get $specdict ARG_INFO] foreach pat $patternlist { + if {[string match $pat @id]} { + #only a single id record can exist + append result \n "@id -id [dict get $specdict id]" + } + if {[string match $pat @cmd]} { + #only a single @cmd record can exist + #merged if multiple in original def (?) + append result \n "@cmd [dict get $specdict cmd_info]" + } + #todo @leaders, @opts, @values lines + #can be multiple of each. We need to preserve order and interleave + #with any matching arg_info results. + #requires storing more info in the internal spec dictionary set matches [dict keys $arg_info $pat] foreach m $matches { set def [dict get $arg_info $m] @@ -1250,9 +1607,9 @@ tcl::namespace::eval punk::args { set realid [real_id $id] if {$realid ne ""} { set speclist [tcl::dict::get $argdefcache_by_id $realid] - set specdict [definition {*}$speclist] - set arg_info [dict get $specdict arg_info] - set valnames [dict get $specdict val_names] + set specdict [define {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] set result "" if {$patternlist eq "*"} { foreach v $valnames { @@ -1280,7 +1637,7 @@ tcl::namespace::eval punk::args { proc get_def {id} { if {[id_exists $id]} { - return [definition {*}[get_spec $id]] + return [define {*}[get_spec $id]] } } proc is_dynamic {id} { @@ -1374,8 +1731,8 @@ tcl::namespace::eval punk::args { #puts -nonewline stderr . ;#debugging - see actual loads if {![catch { if {[info exists ${pkgns}::PUNKARGS]} { - foreach deflist [set ${pkgns}::PUNKARGS] { - namespace eval $pkgns [list punk::args::definition {*}$deflist] + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $pkgns [list punk::args::define {*}$definitionlist] } } if {[info exists ${pkgns}::PUNKARGS_aliases]} { @@ -1432,9 +1789,113 @@ tcl::namespace::eval punk::args { return $cmdinfo } + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::get_spec ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -choices {nocolour info error} + }] ] + #basic recursion blocker variable arg_error_isrunning 0 proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + if {[catch {package require punk::ansi}]} { proc punk::args::a {args} {} proc punk::args::a+ {args} {} @@ -1458,8 +1919,9 @@ tcl::namespace::eval punk::args { set badarg "" set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error + set scheme error dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return} $k] + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] switch -- $fullk { -badarg { set badarg $v @@ -1471,6 +1933,9 @@ tcl::namespace::eval punk::args { } set as_error $v } + -scheme { + set scheme $v + } -return { if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { set arg_error_isrunning 0 @@ -1484,6 +1949,68 @@ tcl::namespace::eval punk::args { } } } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. @@ -1510,13 +2037,13 @@ tcl::namespace::eval punk::args { append errmsg \n } else { if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)[a]" \n } else { append errmsg \n } } - set procname [Dict_getdef $spec_dict cmd_info -name ""] - set prochelp [Dict_getdef $spec_dict cmd_info -help ""] + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] set docurl [Dict_getdef $spec_dict doc_info -url ""] @@ -1531,18 +2058,18 @@ tcl::namespace::eval punk::args { set blank_header_col [list] - if {$procname ne ""} { + if {$cmdname ne ""} { lappend blank_header_col "" - set procname_display [a+ brightwhite]$procname[a] + set cmdname_display $CLR(cmdname)$cmdname[a] } else { - set procname_display "" + set cmdname_display "" } - if {$prochelp ne ""} { + if {$cmdhelp ne ""} { lappend blank_header_col "" - #set prochelp_display [a+ brightwhite]$prochelp[a] - set prochelp_display [textblock::ansibase_lines $prochelp [a+ white]] + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] } else { - set prochelp_display "" + set cmdhelp_display "" } if {$docurl ne ""} { lappend blank_header_col "" @@ -1550,11 +2077,25 @@ tcl::namespace::eval punk::args { } else { set docurl_display "" } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + if {$argdisplay_header ne ""} { lappend blank_header_col "" } if {$use_table} { - set t [textblock::class::table new [a+ brightyellow]Usage[a]] + set t [textblock::class::table new $CLR(title)Usage[a]] $t add_column -headers $blank_header_col -minwidth 3 $t add_column -headers $blank_header_col @@ -1573,19 +2114,19 @@ tcl::namespace::eval punk::args { } } set h 0 - if {$procname ne ""} { + if {$cmdname ne ""} { if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list PROC/METHOD: $procname_display] + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] } else { - lappend errlines "PROC/METHOD: $procname_display" + lappend errlines "COMMAND: $cmdname_display" } incr h } - if {$prochelp ne ""} { + if {$cmdhelp ne ""} { if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $prochelp_display] + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] } else { - lappend errlines "Description: $prochelp_display" + lappend errlines "Description: $cmdhelp_display" } incr h } @@ -1600,6 +2141,17 @@ tcl::namespace::eval punk::args { } incr h } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + if {$use_table} { if {$is_custom_argdisplay} { if {$argdisplay_header ne ""} { @@ -1632,11 +2184,13 @@ tcl::namespace::eval punk::args { set RST [a] #set A_DEFAULT [a+ brightwhite Brightgreen] set A_DEFAULT "" - set A_BADARG [a+ brightred] - set greencheck [a+ brightgreen]\u2713[a] ;#green tick - set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX [a+ green] ;#use a+ so colour off can apply - if {$A_PREFIX eq ""} { + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713[a] ;#green tick + set soloflag $CLR(solo)\u2690[a] ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead set A_PREFIX [a+ underline] set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space } else { @@ -1645,14 +2199,14 @@ tcl::namespace::eval punk::args { set opt_names [list] set opt_names_display [list] - if {[llength [dict get $spec_dict opt_names]]} { + 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 trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] set idents [dict get [$trie shortest_idents ""] scanned] #todo - check opt_prefixdeny $trie destroy - foreach c [dict get $spec_dict opt_names] { + foreach c [dict get $spec_dict OPT_NAMES] { set id [dict get $idents $c] #REVIEW if {$id eq $c} { @@ -1668,12 +2222,12 @@ tcl::namespace::eval punk::args { lappend opt_names $c } } else { - set opt_names [dict get $spec_dict opt_names] + set opt_names [dict get $spec_dict OPT_NAMES] set opt_names_display $opt_names } } - set leading_val_names [dict get $spec_dict leader_names] - set trailing_val_names [dict get $spec_dict val_names] + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { # if {![string match -* $argname]} { @@ -1695,7 +2249,7 @@ tcl::namespace::eval punk::args { lassign $argumentset argnames_display argnames foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict arg_info $arg] + set arginfo [dict get $spec_dict ARG_INFO $arg] if {[dict exists $arginfo -default]} { set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { @@ -1707,6 +2261,13 @@ tcl::namespace::eval punk::args { set choicegroups [Dict_getdef $arginfo -choicegroups {}] set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } if {[dict exists $choicegroups ""]} { dict lappend choicegroups "" {*}$choices } else { @@ -1827,12 +2388,11 @@ tcl::namespace::eval punk::args { #TODO -title directly in list_as_table set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] lappend choicetable_objects $choicetableobj - $choicetableobj configure -title [a+ cyan]$groupname + $choicetableobj configure -title $CLR(groupname)$groupname #append help \n[textblock::join -- " " [$choicetableobj print]] } else { if {$groupname ne ""} { - #bold as well as brightcolour in case colour off. - append help \n \n "[a+ brightyellow bold]Group: $groupname[a]" + append help \n \n "$CLR(groupname)Group: $groupname[a]" } else { append help \n } @@ -1846,15 +2406,15 @@ tcl::namespace::eval punk::args { if {$usetable} { #these will be displayed after all table entries if {$groupname eq ""} { - dict set choicetable_footers "" " [a+ red](no choices defined for main group)[a]" + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)[a]" } else { - dict set choicetable_footers $groupname " [a+ red](no choices defined for group $groupname)[a]" + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)[a]" } } else { if {$groupname eq ""} { - append help \n " " [a+ red](no choices defined)[a] + append help \n " " $CLR(errormsg)(no choices defined)[a] } else { - append help \n " " [a+ red](no choices defined for group $groupname)[a] + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)[a] } } } @@ -1896,13 +2456,16 @@ tcl::namespace::eval punk::args { } } } - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - set argshow "?${argshow}?" + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } } set typeshow [dict get $arginfo -type] if {$typeshow eq "none"} { @@ -1936,7 +2499,13 @@ tcl::namespace::eval punk::args { } ;#end is_custom_argdisplay if {$use_table} { - $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + $t configure -maxwidth 80 ;#review if {$returntype ne "tableobject"} { append errmsg [$t print] @@ -1976,7 +2545,7 @@ tcl::namespace::eval punk::args { } - lappend PUNKARGS [list { + lappend PUNKARGS [list -dynamic 1 { @id -id ::punk::args::usage @cmd -name punk::args::usage -help\ "Return usage information for a command. @@ -1989,6 +2558,7 @@ tcl::namespace::eval punk::args { mechanism and call this as necessary. " -return -default table -choices {string table tableobject} + } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} { @values -min 0 -max 1 id -help\ @@ -1998,11 +2568,12 @@ tcl::namespace::eval punk::args { proc usage {args} { lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received set id [dict get $values id] - set speclist [get_spec $id] - if {[llength $speclist] == 0} { + set definitionlist [get_spec $id] + if {[llength $definitionlist] == 0} { error "punk::args::usage - no such id: $id" } - arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] {*}$opts -aserror 0 + #by placing scheme before the supplied args - it can be overridden + arg_error "" [uplevel 1 [list punk::args::define {*}$definitionlist]] -scheme punk_info {*}$opts -aserror 0 } lappend PUNKARGS [list { @@ -2010,16 +2581,150 @@ tcl::namespace::eval punk::args { @cmd -name punk::args::get_by_id @values -min 1 id - arglist -default "" -type list -help\ + arglist -type list -help\ "list containing arguments to be parsed as per the argument specification identified by the supplied id." }] - proc get_by_id {id {arglist ""}} { - set speclist [punk::args::get_spec $id] - if {[llength $speclist] == 0} { + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::get_spec $id] + if {[llength $definitionlist] == 0} { error "punk::args::get_by_id - no such id: $id" } - return [uplevel 1 [list ::punk::args::get_dict {*}$speclist $arglist]] + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing + record that has been created with ::punk::args::define. + In the 'withdef' form - the definition is created on the + first call and cached thereafter. + + form1: parse ?-flag val?... -- $arglist withid $id + form2: parse ?-flag val?... -- $arglist withdef $def ?$def? + see punk::args::define" + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries. + " + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard minimal} + @values -min 3 + sep -optional 0 -choices "--" + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + set split [lsearch -exact $args --] ;#first -- + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. End of opts marker -- is required even if no options are present." + } + set opts [lrange $args 0 $split-1] ;#repeated flags will override earlier. That's ok here. + set arglist [lindex $args $split+1] + set tailtype [lindex $args $split+2] + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $args $split+3 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $split+3] + return "parse [llength $arglist] args withid $id, options:$opts" + } + withdef { + if {[llength [lrange $args $split+3 end]] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO } #todo? - a version of get_dict that directly supports punk::lib::tstr templating @@ -2031,6 +2736,15 @@ tcl::namespace::eval punk::args { #only supports -flag val pairs, not solo options #If an option is supplied multiple times - only the last value is used. proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + #*** !doctools #[call [fun get_dict] [arg optionspecs] [arg rawargs]] #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values @@ -2065,54 +2779,26 @@ tcl::namespace::eval punk::args { # @values -multiple 1 #} $args - #if {[llength $args] == 0} { - # set rawargs [list] - #} elseif {[llength $args] ==1} { - # set rawargs [lindex $args 0] ;#default tcl style - #} else { - # #todo - can we support tk style vals before flags? - # #the aim is to allow a single call to validate standard leading proc positional args along with the $args val which may have flags in tk or tcl order - # #by allowing all to be in a single call - we could use a -help (or similar erroring call) to trigger the spec-parsing from a wrapper function. - # #this would be important in the case where the function to be wrapped has never been called - but the wrapper needs info about the downstream options - # #we would like to avoid the ugliness of trying to parse a proc body to scrape the specification. - # #we may still need to do a basic scan of the proc body to determine if it at least contains the string punk::args::get_dict - but that is slightly less odious. - # error "unsupported number of arguments for punk::args::get_dict" - # set inopt 0 - # set k "" - # set i 0 - # foreach a $args { - # switch -- $f { - # -opts { - - # } - # -vals { - - # } - # -optvals { - # #tk style - - # } - # -valopts { - # #tcl style - # set rawargs [lindex $args $i+1] - # incr i - # } - # default { - - # } - # } - # incr i - # } - #} set is_dynamic 0 if {[lindex $args 0] eq "-dynamic"} { set is_dynamic [lindex $args 1] } set rawargs [lindex $args end] ;# args values to be parsed - set def_args [lrange $args 0 end-1] - set argspecs [uplevel 1 [list ::punk::args::definition {*}$def_args]] + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::define {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + #puts "-arg_info->$arg_info" set flagsreceived [list] ;#for checking if required flags satisfied #secondary purpose: @@ -2128,31 +2814,31 @@ tcl::namespace::eval punk::args { set opts $opt_defaults set pre_values {} - set argnames [tcl::dict::keys $arg_info] + set argnames [tcl::dict::keys $ARG_INFO] set optnames [lsearch -all -inline $argnames -*] set ridx 0 set rawargs_copy $rawargs set leader_posn_name "" set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) set is_multiple 0 ;#last leader may be multi - if {$leader_max != 0} { + if {$LEADER_MAX != 0} { foreach r $rawargs_copy { - if {$leader_max ne "" && $leader_max != -1 && $ridx > $leader_max-1} { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { break } - if {$ridx == [llength $leader_names]-1} { + if {$ridx == [llength $LEADER_NAMES]-1} { #at last named leader - set leader_posn_name [lindex $leader_names $ridx] - if {[dict exists $arg_info $leader_posn_name -multiple] && [dict get $arg_info $leader_posn_name -multiple]} { + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { set is_multiple 1 } - } elseif {$ridx > [llength $leader_names]-1} { + } elseif {$ridx > [llength $LEADER_NAMES]-1} { #beyond names - retain name if -multiple was true if {!$is_multiple} { set leader_posn_name "" } } else { - set leader_posn_name [lindex $leader_names $ridx] ;#may return empty string + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string } if {$r eq "--"} { #review end of opts marker: '--' can't be a leader (but can be a value) @@ -2181,7 +2867,7 @@ tcl::namespace::eval punk::args { #for each branch - break or lappend if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $leader_required} { + if {$leader_posn_name ni $LEADER_REQUIRED} { #optional leader #most adhoc arg processing will allocate based on number of args rather than matching choice values first @@ -2220,11 +2906,11 @@ tcl::namespace::eval punk::args { } } else { #unnamed leader - if {$leader_min ne "" } { - if {$ridx > $leader_min} { + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { break } else { - #haven't reached leader_min + #haven't reached LEADER_MIN lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } @@ -2234,16 +2920,24 @@ tcl::namespace::eval punk::args { } incr ridx - } + } ;# end foreach r $rawargs_copy } - if {$leader_min eq ""} { - set leader_min 0 + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN } - if {$leader_max eq ""} { - set leader_max -1 + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX } - #assert leader_max leader_min are numeric + #assert leadermax leadermin are numeric #assert - rawargs has been reduced by leading positionals set leaders [list] @@ -2251,7 +2945,7 @@ tcl::namespace::eval punk::args { set post_values {} #val_min, val_max #puts stderr "rawargs: $rawargs" - #puts stderr "arg_info: $arg_info" + #puts stderr "argstate: $argstate" if {[lsearch $rawargs -*] >= 0} { #at least contains flaglike things.. set maxidx [expr {[llength $rawargs] -1}] @@ -2298,9 +2992,9 @@ tcl::namespace::eval punk::args { } break } else { - set fullopt [tcl::prefix match -error "" $opt_names $a] + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] if {$fullopt ne ""} { - if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { #non-solo #check if it was actually a value that looked like a flag if {$i == $maxidx} { @@ -2312,7 +3006,7 @@ tcl::namespace::eval punk::args { } set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $argstate $fullopt -multiple]} { #don't lappend to default - we need to replace if there is a default if {$fullopt ni $flagsreceived} { tcl::dict::set opts $fullopt [list $flagval] @@ -2329,7 +3023,7 @@ tcl::namespace::eval punk::args { } } else { #solo - if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $argstate $fullopt -multiple]} { if {$fullopt ni $flagsreceived} { #override any default - don't lappend to it tcl::dict::set opts $fullopt 1 @@ -2359,10 +3053,10 @@ tcl::namespace::eval punk::args { if {$opt_any} { set newval [lindex $rawargs $i+1] #opt was unspecified but is allowed due to @opts -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::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { tcl::dict::lappend opts $a $newval } else { tcl::dict::set opts $a $newval @@ -2373,7 +3067,7 @@ tcl::namespace::eval punk::args { 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::get $argstate $a -multiple]} { if {![tcl::dict::exists $opts $a]} { tcl::dict::set opts $a 1 } else { @@ -2386,8 +3080,8 @@ tcl::namespace::eval punk::args { } lappend flagsreceived $a ;#adhoc flag as supplied } else { - if {[llength $opt_names]} { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" + if {[llength $OPT_NAMES]} { + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" } else { set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" } @@ -2419,15 +3113,15 @@ tcl::namespace::eval punk::args { set ldridx 0 set in_multiple "" set leadernames_received [list] - set leaders_dict $leader_defaults + set leaders_dict $LEADER_DEFAULTS set num_leaders [llength $leaders] - foreach leadername $leader_names ldr $leaders { + foreach leadername $LEADER_NAMES ldr $leaders { if {$ldridx+1 > $num_leaders} { break } if {$leadername ne ""} { - if {[tcl::dict::get $arg_info $leadername -multiple]} { - if {[tcl::dict::exists $leader_defaults $leadername]} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list } else { tcl::dict::lappend leaders_dict $leadername $ldr @@ -2443,8 +3137,8 @@ tcl::namespace::eval punk::args { lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) } else { tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set arg_info $positionalidx $leaderspec_defaults - tcl::dict::set arg_checks $positionalidx $leader_checks_defaults + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS lappend leadernames_received $positionalidx } } @@ -2457,12 +3151,12 @@ tcl::namespace::eval punk::args { set valnames_received [list] set values_dict $val_defaults set num_values [llength $values] - foreach valname $val_names val $values { + foreach valname $VAL_NAMES val $values { if {$validx+1 > $num_values} { break } if {$valname ne ""} { - if {[tcl::dict::get $arg_info $valname -multiple]} { + if {[tcl::dict::get $argstate $valname -multiple]} { if {[tcl::dict::exists $val_defaults $valname]} { #current stored val equals defined default - don't include default in the list we build up tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list @@ -2481,8 +3175,8 @@ tcl::namespace::eval punk::args { lappend valnames_received $in_multiple } else { tcl::dict::set values_dict $positionalidx $val - tcl::dict::set arg_info $positionalidx $valspec_defaults - tcl::dict::set arg_checks $positionalidx $val_checks_defaults + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS lappend valnames_received $positionalidx } } @@ -2490,17 +3184,17 @@ tcl::namespace::eval punk::args { incr positionalidx } - if {$leader_max == -1} { + if {$leadermax == -1} { #only check min - if {$num_leaders < $leader_min} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leader_min" $argspecs + if {$num_leaders < $leadermin} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs } } else { - if {$num_leaders < $leader_min || $num_leaders > $leader_max} { - if {$leader_min == $leader_max} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leader_min" $argspecs + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs } else { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leader_min and $leader_max inclusive" $argspecs + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs } } } @@ -2541,7 +3235,7 @@ tcl::namespace::eval punk::args { # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $leader_required $leadernames_received]]]} { + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs } if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { @@ -2560,9 +3254,9 @@ tcl::namespace::eval punk::args { set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash #puts "---opts_and_values:$opts_and_values" - #puts "---arg_info:$arg_info" + #puts "---argstate:$argstate" tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $arg_info $argname] + set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] set thisarg_checks [tcl::dict::get $arg_checks $argname] set is_multiple [tcl::dict::get $thisarg -multiple] @@ -3471,10 +4165,10 @@ tcl::namespace::eval punk::args::lib { #for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. #arguably it may be more processor-cache-efficient to do together like this anyway. -#can't do this - as there is circular dependency with punk::lib +#can't do this here? - as there is circular dependency with punk::lib #tcl::namespace::eval punk::args { # foreach deflist $PUNKARGS { -# punk::args::definition {*}$deflist +# punk::args::define {*}$deflist # } # set PUNKARGS "" #} diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm index ec174d19..25fad906 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm @@ -208,7 +208,7 @@ tcl::namespace::eval punk::args::tclcore { #todo - make generic - take command and known_groups_dict proc info_subcommands {} { package require punk::ns - set subdict [punk::ns::ensemble_subcommands info] + set subdict [punk::ns::ensemble_subcommands -return dict info] set allsubs [dict keys $subdict] dict set groups "system" {hostname library nameofexecutable patchlevel script sharedlibextension tclversion} dict set groups "{proc introspection}" {args body default} @@ -234,8 +234,58 @@ tcl::namespace::eval punk::args::tclcore { } append argdef " \}" \n + #todo -choicelabels + #detect subcommand further info available e.g if oo or ensemble or punk::args id exists.. + #consider a different mechanism to add a label on rhs of same line as choice (for (i) marker) + return $argdef } + + + lappend PUNKARGS [list -dynamic 1 { + #test of @form + @id -id ::AFTER + @cmd -name "Builtin: after" -help\ + "Execute a command after a time delay." + + # ---------- shared elements ------------- + @ref -id common_script_help -help\ + "script argument to be concatenated in the same fashion as the concat command" + # ---------- shared elements ------------- + + @form -form {delay} -synopsis "after ms" + @form -form {schedule_ms} -synopsis "after ms ?script...?" + + #@values -form {*} #note "classify next argument as a value not a leader" + ms -form {*} -type int + @values -form {delay} -min 1 -max 1 + @values -form {schedule_ms} -min 2 + script -form {schedule_ms} -multiple 1 -optional 1 ref-help common_script_help + + + @form -form {cancelid} -synopsis "after cancel id" + @values + cancel -choices {cancel} + id + + + @form -form {cancelscript} -synopsis "after cancel script ?script...?" + @values -min 2 + cancel -choices {cancel} + script -multiple 1 -optional 0 ref-help common_script_help + + + @form -form {schedule_idle} -synopsis "after idle script ?script...?" + @values -min 1 + idle -choices {idle} + script -multiple 1 -optional 1 ref-help common_script_help + + @form -form {info} -synopsis "after info ?id?" + info -choices {info} + id -optional 1 + + } "@doc -name Manpage: -url [manpage_tcl after]" ] + lappend PUNKARGS [list -dynamic 1 { @id -id ::info @cmd -name "Builtin: info" -help\ @@ -290,11 +340,11 @@ tcl::namespace::eval punk::args::tclcore { characters are used. When decoding, upper and lower characters are accepted." } "@doc -name Manpage: -url [manpage_tcl binary]" ] lappend PUNKARGS [list { - @id -id "::tcl::binary::encode::hex" - @default -id (default)::tcl::binary::*::hex - @cmd -name "binary encode hex" - @values -min 1 -max 1 - data -type string + @id -id "::tcl::binary::encode::hex" + @default -id (default)::tcl::binary::*::hex + @cmd -name "binary encode hex" + @values -min 1 -max 1 + data -type string } ] lappend PUNKARGS [list { @id -id "::tcl::binary::decode::hex" @@ -534,7 +584,7 @@ tcl::namespace::eval punk::args::tclcore { value -type any -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl lappend]"] - punk::args::definition { + punk::args::define { @id -id ::ledit @cmd -name "builtin: ledit" -help\ "Replace elements of a list stored in variable @@ -547,7 +597,7 @@ tcl::namespace::eval punk::args::tclcore { value -type any -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl ledit]" - punk::args::definition { + punk::args::define { @id -id ::lpop @cmd -name "builtin: lpop" -help\ "Get and remove an element in a list @@ -567,7 +617,7 @@ tcl::namespace::eval punk::args::tclcore { in sublists, similar to lindex and lset." } "@doc -name Manpage: -url [manpage_tcl lpop]" - punk::args::definition { + punk::args::define { @id -id ::lrange @cmd -name "builtin: lrange" -help\ "return one or more adjacent elements from a list. @@ -587,23 +637,23 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl lrange]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::cat @cmd -name "builtin: tcl::string::cat" -help\ - "Concatente the given strings just like placing them directly next to each other and + "Concatenate the given strings just like placing them directly next to each other and return the resulting compound string. If no strings are present, the result is an empty string. This primitive is occasionally handier than juxtaposition of strings when mixed quoting is wanted, or when the aim is to return the result of a concatentation without resorting to return -level 0, and is more efficient than building a list of arguments and using join with an empty join string." - + @form -synopsis "string cat ?string...?" @values -min 0 -max -1 string -type string -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::compare @cmd -name "builtin: tcl::string::compare" -help\ @@ -623,7 +673,7 @@ tcl::namespace::eval punk::args::tclcore { string2 -type string } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::equal @cmd -name "builtin: tcl::string::equal" -help\ @@ -642,7 +692,7 @@ tcl::namespace::eval punk::args::tclcore { string2 -type string } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::first @cmd -name "builtin: tcl::string::first" -help\ "Search haystackString for a sequence of characters that exactly match the characters @@ -658,7 +708,7 @@ tcl::namespace::eval punk::args::tclcore { "integer or simple expression." } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::insert @cmd -name "builtin: tcl::string::insert" -help\ "Returns a copy of string with insertString inserted at the index'th character. @@ -679,7 +729,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::last @cmd -name "builtin: tcl::string::last" -help\ "Search haystackString for a sequence of characters that exactly match the characters @@ -695,7 +745,7 @@ tcl::namespace::eval punk::args::tclcore { "integer or simple expression." } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::repeat @cmd -name "builtin: tcl::string::repeat" -help\ "Returns a string consisting of string concatenated with itself count times." @@ -705,7 +755,7 @@ tcl::namespace::eval punk::args::tclcore { "If count is 0, the empty string will be returned." } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::replace @cmd -name "builtin: tcl::string::replace" -help\ "Removes a range of consecutive characters from string, starting with the character whose @@ -725,7 +775,7 @@ tcl::namespace::eval punk::args::tclcore { "If newstring is specified, then it is placed in the removed character range." } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::totitle @cmd -name "builtin: tcl::string::totitle" -help\ "Returns a value equal to string except that the first character in string is converted to @@ -740,7 +790,7 @@ tcl::namespace::eval punk::args::tclcore { "If last is specified, it refers to the char index in the string to stop at (inclusive)." } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::wordend @cmd -name "builtin: tcl::string::wordend" -help\ "Returns the index of the character just after the last one in the word containing @@ -756,7 +806,7 @@ tcl::namespace::eval punk::args::tclcore { e.g M+N" } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::tcl::string::wordstart @cmd -name "builtin: tcl::string::wordstart" -help\ "Returns the index of the first character in the word containing @@ -773,7 +823,7 @@ tcl::namespace::eval punk::args::tclcore { e.g M+N" } "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition [punk::lib::tstr -return string { + punk::args::define [punk::lib::tstr -return string { @id -id ::tcl::string::is @cmd -name "builtin: tcl::string::is" -help\ "Returns 1 if string is a valid member of the specified character class, otherwise returns 0. @@ -932,7 +982,7 @@ tcl::namespace::eval punk::args::tclcore { string -type string -optional 0 }] "@doc -name Manpage: -url [manpage_tcl string]" - punk::args::definition { + punk::args::define { @id -id ::zlib @cmd -name "builtin: ::zlib" -help\ "zlib - compression and decompression operations @@ -960,7 +1010,7 @@ tcl::namespace::eval punk::args::tclcore { } } "@doc -name Manpage: -url [manpage_tcl zlib]" - punk::args::definition { + punk::args::define { @id -id "::zlib adler32" @cmd -name "builtin: ::zlib adler32" -help\ "Compute a checksum of binary string ${$I}string${$NI} using the Adler32 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 e6257866..aaf3bf3c 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 @@ -119,7 +119,7 @@ tcl::namespace::eval punk::blockletter { set logo_letter_colours [list Web-red Web-green Web-royalblue Web-purple Web-orange] set logo_letter_colours [list Red Green Blue Purple Yellow] - punk::args::definition [tstr -return string { + punk::args::define [tstr -return string { @id -id ::punk::blockletter::logo -frametype -default {${$default_frametype}} -outlinecolour -default "web-white" @@ -218,7 +218,7 @@ tcl::namespace::eval punk::blockletter { append out [textblock::join_basic -- $left $centre $right] } - punk::args::definition [tstr -return string { + punk::args::define [tstr -return string { @id -id ::punk::blockletter::text -bgcolour -default "Web-red" -bordercolour -default "web-white" @@ -280,7 +280,9 @@ tcl::namespace::eval punk::blockletter::lib { #} - punk::args::definition [tstr -return string { + #use tstr when resolving params as a one-off at definition time + #versus slower -dynamic 1 if defaults/choices etc need to reflect the current state of the system. + punk::args::define [tstr -return string { @id -id ::punk::blockletter::block -height -default 2 -width -default 4 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm index 3024053b..8cb06b1f 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm @@ -1246,6 +1246,10 @@ tcl::namespace::eval punk::char { return [charset_dict "Box Drawing"] } + proc char_hex {char} { + return [format %08x [scan $char %c]] + } + proc char_info_hex {hex args} { set hex [tcl::string::map [list _ ""] $hex] if {[tcl::string::is xdigit -strict $hex]} { 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 d2c08e8b..74365afa 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 @@ -1186,7 +1186,7 @@ namespace eval punk::console { #todo - change -inoutchannels to -terminalobject with prebuilt default - punk::args::definition { + punk::args::define { @id -id ::punk::console::cell_size -inoutchannels -default {stdin stdout} -type list @values -min 0 -max 1 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm index 6de20bff..1f02859b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm @@ -1251,7 +1251,7 @@ namespace eval punk::fileline { #[para] Core API functions for punk::fileline #[list_begin definitions] - punk::args::definition { + punk::args::define { @id -id ::punk::fileline::get_textinfo @cmd -name punk::fileline::get_textinfo -help\ "return: textinfo object instance" diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/loadedlib-0.1.0.tm index f427f29f..b5539021 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -26,7 +26,7 @@ package require punk::lib namespace eval punk::mix::commandset::loadedlib { namespace export * #search automatically wrapped in * * - can contain inner * ? globs - punk::args::definition { + punk::args::define { @id -id ::punk::mix::commandset::loadedlib::search @cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" -return -type string -default table -choices {table tableobject list lines} diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm index 2079eb8c..41206d0c 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm @@ -141,7 +141,7 @@ namespace eval punk::mix::commandset::module { set moduletypes [punk::mix::cli::lib::module_types] - punk::args::definition [subst { + punk::args::define [subst { @id -id ::punk::mix::commandset::module::new @cmd -name "punk::mix::commandset::module::new" -help\ "Create a new module file in the appropriate folder within src/modules. 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 3f5f3a71..5d601b3a 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 @@ -636,7 +636,7 @@ tcl::namespace::eval punk::nav::fs { # c:/repo/jn/punk/../../blah #dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold # dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream - punk::args::definition { + punk::args::define { @id -id ::punk::nav::fs::dirfiles -stripbase -default 1 -type boolean -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" @@ -992,7 +992,7 @@ tcl::namespace::eval punk::nav::fs { return [dict merge $listing $updated] } - punk::args::definition { + punk::args::define { @id -id ::punk::nav::fs::dirfiles_dict_as_lines -stripbase -default 0 -type boolean -formatsizes -default 1 -type boolean 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 f8a1e939..6235224a 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 @@ -1893,7 +1893,31 @@ tcl::namespace::eval punk::ns { } } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} $vline" set idauto "(autodef)$origin" - set argspec [punk::lib::tstr -return string { + set argdef [punk::lib::tstr -return string { @id -id ${$idauto} @cmd -name "Object: ${$origin}" -help\ "Instance of class: ${$class} (info autogenerated)" @values -min 1 }] - append argspec \n $vline - punk::args::definition $argspec + append argdef \n $vline + punk::args::define $argdef return [punk::args::usage {*}$opts $idauto] } privateObject { @@ -2457,7 +2502,8 @@ tcl::namespace::eval punk::ns { set match [tcl::prefix::match $subcommands [lindex $queryargs 0]] if {$match in $subcommands} { set subcmd [dict get $subcommand_dict $match] - return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + return [arginfo {*}$opts {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") } } @@ -2491,15 +2537,15 @@ tcl::namespace::eval punk::ns { set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] set autoid "(autodef)$origin" - set argspec [punk::lib::tstr -return string { + set argdef [punk::lib::tstr -return string { @id -id ${$autoid} @cmd -help\ "(autogenerated) ensemble: ${$origin}" @values -min 1 }] - append argspec \n $vline - punk::args::definition $argspec + append argdef \n $vline + punk::args::define $argdef return [punk::args::usage {*}$opts $autoid] } @@ -2918,7 +2964,7 @@ tcl::namespace::eval punk::ns { } interp alias "" use "" punk::ns::pkguse - punk::args::definition { + punk::args::define { @id -id ::punk::ns::nsimport_noclobber @cmd -name punk::ns::nsimport_noclobber -help\ "Import exported commands from a namespace into either the current namespace, diff --git a/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm index 65ede7c8..ede3e18b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm @@ -644,7 +644,7 @@ namespace eval punk::path { return $ismatch } - punk::args::definition { + punk::args::define { @id -id ::punk::path::treefilenames -directory -type directory -help\ "folder in which to begin recursive scan for files." 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 70c34c4a..9859ed8e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm @@ -1580,7 +1580,7 @@ proc punk::repl::console_debugview {editbuf consolewidth args} { set spacepatch [textblock::block $debug_width $patch_height " "] puts -nonewline [punk::ansi::cursor_off] #use non cursorsave versions - cursor save/restore will interfere with any concurrent ansi rendering that uses save/restore - because save/restore is a single item, not a stack. - set debug_offset [[expr {$consolewidth - $debug_width - $opt_rightmargin}]] + set debug_offset [expr {$consolewidth - $debug_width - $opt_rightmargin}] set row_clear [expr {$opt_row -2}] punk::console::move_emitblock_return $row_clear $debug_offset $spacepatch punk::console::move_emitblock_return $opt_row $debug_offset $info 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 98bc04ef..063a13c0 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 @@ -65,6 +65,22 @@ namespace eval punk::repo { variable PUNKARGS variable PUNKARGS_aliases + variable cached_command_paths + set cached_command_paths [dict create] + #anticipating possible removal of buggy caching from auto_execok + #mentioned in: https://core.tcl-lang.org/tcl/tktview/4dc35e0c0c + #this would leave the application to decide what it wants to cache in that regard. + proc Cached_auto_execok {name} { + return [auto_execok $name] + #variable cached_command_paths + #if {[dict exists $cached_command_paths $name]} { + # return [dict get $cached_command_paths $name] + #} + #set resolved [auto_execok $name] + #dict set cached_command_paths $name $resolved + #return $resolved + } + proc get_fossil_usage {} { set allcmds [runout -n fossil help -a] set mainhelp [runout -n fossil help] @@ -197,7 +213,7 @@ namespace eval punk::repo { #emit warning whether or not multiple fossil repos puts stdout [dict get $repostate warnings] } - set fossil_prog [auto_execok fossil] + set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog ne ""} { {*}$fossil_prog {*}$args } else { @@ -222,7 +238,10 @@ namespace eval punk::repo { #uppercase FOSSIL to bypass fossil as alias to fossil_proxy + #only necessary on unix? + #Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway proc establish_FOSSIL {args} { + #review if {![info exists ::auto_execs(FOSSIL)]} { set ::auto_execs(FOSSIL) [auto_execok fossil] ;#may fail in safe interp } @@ -499,7 +518,7 @@ namespace eval punk::repo { #For this reason we will store 'unchanged' records for both git and fossil so that the combined dict should represent all files in the revision if {$rt eq "fossil"} { dict set resultdict repotype fossil - set fossil_cmd [auto_execok fossil] + set fossil_cmd [Cached_auto_execok fossil] if {$fossil_cmd eq ""} { error "workingdir_state error: fossil executable doesn't seem to be available" } @@ -598,7 +617,7 @@ namespace eval punk::repo { break } elseif {$rt eq "git"} { dict set resultdict repotype git - set git_cmd [auto_execok git] + set git_cmd [Cached_auto_execok git] # -uno = suppress ? lines. # -b = show ranch and tracking info #our basic parsing/grepping assumes --porcelain=2 @@ -988,7 +1007,7 @@ namespace eval punk::repo { } proc fossil_get_repository_file {{path {}}} { if {$path eq {}} { set path [pwd] } - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set fossilinfo [::exec {*}$fossilcmd info] @@ -1073,7 +1092,7 @@ namespace eval punk::repo { set startdir $opt_parentfolder - set fossil_prog [auto_execok fossil] + set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog eq ""} { puts stderr "Fossil not found. Please install fossil" return @@ -1319,7 +1338,7 @@ namespace eval punk::repo { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[Cached_auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } @@ -1332,7 +1351,7 @@ namespace eval punk::repo { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[Cached_auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } @@ -1343,7 +1362,7 @@ namespace eval punk::repo { proc fossil_revision {{path {}}} { if {$path eq {}} { set path [pwd] } # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set info [::exec {*}$fossilcmd info] @@ -1357,7 +1376,7 @@ namespace eval punk::repo { proc fossil_remote {{path {}}} { if {$path eq {}} { set path [pwd] } # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set info [::exec {*}$fossilcmd remote ls] @@ -1423,7 +1442,7 @@ namespace eval punk::repo { set original_cwd [pwd] #attempt2 - let fossil do it for us - hopefully based on current folder if {$path eq {}} {set path [pwd]} - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {![llength $fossilcmd]} { set fossil_ok 0 } else { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm index 90851b29..2b38dbb3 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm @@ -458,7 +458,7 @@ tcl::namespace::eval punk::safe { # If we have exactly 2 arguments the semantic is a "configure get" lassign $args child arg - set spec_dict [punk::args::definition [punk::args::get_spec punk::safe::interpIC]] + set spec_dict [punk::args::define [punk::args::get_spec punk::safe::interpIC]] set opt_names [dict get $spec_dict opt_names] CheckInterp $child @@ -761,7 +761,7 @@ tcl::namespace::eval punk::safe::system { append OPTS \n {-autoPath -type list -default {} -help\ "::auto_path for the child"} } - punk::args::definition $OPTS + punk::args::define $OPTS set optlines [punk::args::get_spec punk::safe::OPTS -*] set INTERPCREATE { @@ -775,7 +775,7 @@ tcl::namespace::eval punk::safe::system { } append INTERPCREATE \n $optlines append INTERPCREATE \n {@values -max 0} - punk::args::definition $INTERPCREATE + punk::args::define $INTERPCREATE set INTERPIC { @@ -786,7 +786,7 @@ tcl::namespace::eval punk::safe::system { } append INTERPIC \n $optlines append INTERPIC \n {@values -max 0} - punk::args::definition $INTERPIC + punk::args::define $INTERPIC #### diff --git a/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm index 62596f5d..6da53230 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm @@ -141,7 +141,7 @@ tcl::namespace::eval punk::sixel { #non-sixel characters ignored (? review) #we will for now consume all to final ST #TODO - sixel row/col info is dependent on terminal - pass in -terminalobject or -inoutchannels (for use with punk::console::cell_size) - punk::args::definition { + punk::args::define { @id -id ::punk::sixel::get_info @cmd -name punk::sixel::get_info -help\ "return a dict of information about the supplied sixelstring" diff --git a/src/vfs/_vfscommon.vfs/modules/punk/winshell-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/winshell-0.1.0.tm new file mode 100644 index 00000000..e0c738ef --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/winshell-0.1.0.tm @@ -0,0 +1,376 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::winshell 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::winshell 0 0.1.0] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::winshell] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::winshell +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::winshell +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::winshell::class { + #*** !doctools + #[subsection {Namespace punk::winshell::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::winshell { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::winshell}] + #[para] Core API functions for punk::winshell + #[list_begin definitions] + + + #The windows api we need here is createPseudoConsole et al. + + variable autoshellid 0 + variable shellinfo [dict create] + + #test of exec and named pipes. + #we don't get a console + proc cmdexec {{id ""}} { + variable autoshellid + variable shellinfo + package require twapi + set pipebase {\\.\pipe\punkwinshell} + if {$id eq ""} { + incr autoshellid + set shellid $autoshellid + } else { + set shellid $id + } + + set pipename_stdin $pipebase$shellid-stdin + set pipename_stdout $pipebase$shellid-stdout + set pipename_stderr $pipebase$shellid-stderr + set h_stdin [twapi::namedpipe_server $pipename_stdin] ;#handle for child process redirection + set p_stdin [twapi::namedpipe_client $pipename_stdin] ;#this end + set h_stdout [twapi::namedpipe_server $pipename_stdout] ;#handle for child process redirection + set p_stdout [twapi::namedpipe_client $pipename_stdout] ;#this end + chan configure $p_stdout -blocking 0 + set h_stderr [twapi::namedpipe_server $pipename_stderr] ;#handle for child process redirection + set p_stderr [twapi::namedpipe_client $pipename_stderr] ;#this end + chan configure $p_stderr -blocking 0 + + set pid [exec cmd.exe /k >@$h_stdout 2>@$h_stderr <@$h_stdin &] + dict set shellinfo $shellid id $shellid + dict set shellinfo $shellid pid $pid + dict set shellinfo $shellid stdin $p_stdin + dict set shellinfo $shellid stdout $p_stdout + dict set shellinfo $shellid stderr $p_stderr + + return [dict get $shellinfo $shellid] + } + + #test with twapi create_process + proc cmdcreate {{id ""}} { + variable autoshellid + variable shellinfo + package require twapi + set pipebase {\\.\pipe\punkwinshell} + if {$id eq ""} { + incr autoshellid + set shellid $autoshellid + } else { + set shellid $id + } + + + #Method 1) - using windows named pipes + set pipename_stdin $pipebase$shellid-stdin + set pipename_stdout $pipebase$shellid-stdout + set pipename_stderr $pipebase$shellid-stderr + #set h_stdin [twapi::namedpipe_server $pipename_stdin] ;#handle for child process redirection - child to read + #set p_stdin [twapi::namedpipe_client $pipename_stdin] ;#this end for writing + + #set h_stdout [twapi::namedpipe_server $pipename_stdout] ;#handle for child process redirection - child to write + #set p_stdout [twapi::namedpipe_client $pipename_stdout] ;#this end for reading + #set h_stderr [twapi::namedpipe_server $pipename_stderr] ;#handle for child process redirection - child to write + #set p_stderr [twapi::namedpipe_client $pipename_stderr] ;#this end for reading + + #test + set p_stdout [twapi::namedpipe_server $pipename_stdout] ;#handle for child process redirection - child to write + set p_stdin "" + set p_stderr "" + chan configure $p_stdout -blocking 0 + + + #Method 2) - using tcl's 'chan pipe' which creates OS level channels + #chan pipe returns rd wr channels in that order + #lassign [chan pipe] h_stdin p_stdin + #lassign [chan pipe] p_stdout h_stdout + #lassign [chan pipe] p_stderr h_stderr + + #chan configure $p_stdout -blocking 0 + #chan configure $p_stderr -blocking 0 + + #set cmd {C:\Users\sleek\scoop\apps\windows-terminal\current\WindowsTerminal.exe} ;#doesn't work? + #set cmd "[auto_execok cmd.exe] /k" + #set cmd "[auto_execok powershell] -nop" + #set cmd "[auto_execok tclsh]" + set cmd "[auto_execok tclsh90]" + + set flagdict [dict create\ + -cmdline "$cmd"\ + -newconsole 1\ + -inherithandles 0\ + -background blue\ + -title "punk::winshell $shellid" + ] + + #dict set flagdict -stdchannels [list $h_stdin $h_stdout $h_stderr] + + set program "" + lassign [twapi::create_process $program {*}$flagdict] pid tid + + + puts stdout "launched with pid:$pid tid:$tid" + #set pid [exec cmd.exe /k >@$h_stdout 2>@$h_stderr <@$h_stdin &] + + dict set shellinfo $shellid id $shellid + dict set shellinfo $shellid pid $pid + dict set shellinfo $shellid type "create_process" + dict set shellinfo $shellid stdin $p_stdin + dict set shellinfo $shellid stdout $p_stdout + dict set shellinfo $shellid stderr $p_stderr + + return [dict get $shellinfo $shellid] + } + proc cmdexit {shellid} { + variable shellinfo + set info [dict get $shellinfo $shellid] + switch -- [dict get $info type] { + "create_process" { + set exitresult [twapi::end_process [dict get $info pid]] + } + "exec" { + puts stderr "todo.." + puts stderr "manually kill exec process [dict get $info pid]" + set exitresult 0 + } + } + return [dict create exitresult $exitresult] + } + + proc cmdkill {shellid} { + variable shellinfo + set info [dict get $shellinfo $shellid] + set pid [dict get $info pid] + set killcmd [list taskkill /PID $pid] + + if {[catch { + exec {*}$killcmd + } errMsg]} { + puts stderr "$killcmd returned an error:" + puts stderr $errMsg + #if {!$forcekill} { + # puts stderr "(try 'kill -9 $pid' ??)" + #} + + #review - *no running instance* works with windows taskkill - "*No such process*" works with kill -9 on FreeBSD and linux - other platforms? + if {![string match "*no running instance*" $errMsg] && ![string match "*No such process*" $errMsg]} { + lappend failed_kits [list kit $targetkit reason "could not kill running process for $targetkit (using '$killcmd')"] + continue + } else { + puts stderr " + } + } else { + puts stderr "$killcmd ran without error" + incr count_killed + } + + } + + proc cmdinfo {{id ""}} { + variable autoshellid + variable shellinfo + if {$id eq ""} { + #last created + set shellid $autoshellid + } else { + set shellid $id + } + set info [dict get $shellinfo $shellid] + set pid [dict get $info pid] + + set statusresult [tcl::process status $pid] + dict set info status $statusresult + set cmdline [twapi::get_process_commandline $pid] + dict set info cmdline $cmdline + return [showdict $info] + } + + #quick n dirty - status of last (or identified) winshell + proc cmdstat {{id ""}} { + variable autoshellid + variable shellinfo + if {$id eq ""} { + #last created + set shellid $autoshellid + } else { + set shellid $id + } + set pid [dict get $shellinfo $shellid pid] + set statusresult [tcl::process status $pid] + return [dict create id $shellid status $statusresult] + } + + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::winshell ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::winshell::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::winshell::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::winshell::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::winshell::system { + #*** !doctools + #[subsection {Namespace punk::winshell::system}] + #[para] Internal functions that are not part of the API + + + +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::winshell [tcl::namespace::eval punk::winshell { + variable pkg punk::winshell + variable version + set version 0.1.0 +}] +return + +#*** !doctools +#[manpage_end] + 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 dcc023ec..a3d5b967 100644 --- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm @@ -8367,7 +8367,7 @@ tcl::namespace::eval textblock { foreach tline $tlines { if {[tcl::string::first $FSUB $tline] >= 0} { set content_line [lindex $clines $contentindex] - if {[tcl::string::first $R $content_line] == 0} { + if {[tcl::string::first $R [string range $content_line 0 10]] == 0} { set content_line [tcl::string::range $content_line $rlen end] } #make sure to replay opt_ansibase to the right of the replacement diff --git a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm new file mode 100644 index 00000000..32450e55 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm @@ -0,0 +1,8567 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix 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. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application textblock 0.1.3 +# Meta platform tcl +# Meta license +# @@ Meta End + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_textblock 0 0.1.3] +#[copyright "2024"] +#[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 ansi text layout colour table frame console terminal] +#[description] +#[para] Ansi-aware terminal textblock manipulation + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of textblock +#[subsection Concepts] +#[para] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by textblock +#[list_begin itemized] + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] +#[item] [package {punk::char}] +#[item] [package {punk::ansi}] +#[item] [package {punk::lib}] +#[item] [package {overtype}] +#[item] [package {term::ansi::code::macros}] +#[item] [package {textutil}] + +## Requirements +package require Tcl 8.6- +package require punk::args +package require punk::char +package require punk::ansi +package require punk::lib +catch {package require patternpunk} +package require overtype + +#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. +if {[catch { + package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? +} errM]} { + #catch this too in case stderr not available + catch { + puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM" + } +} +package require textutil + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval textblock { + #review - what about ansi off in punk::console? + tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ + tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock + + #NOTE sha1, although computationally more intensive, tends to be faster than md5 on modern cpus + #(more likely to be optimised for modern cpu features?) + #(This speed improvement may not apply for short strings) + + variable use_hash ;#framecache + set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display + #if {![catch {package require sha1}]} { + # set use_hash sha1 + #} elseif {![catch {package require md5}]} { + # set use_hash md5 + #} else { + # set use_hash none + #} + + proc use_hash {args} { + set choices [list none] + set unavailable [list] + set pkgs [package names] + if {"md5" in $pkgs} { + lappend choices md5 + } else { + lappend unavailable md5 + } + if {"sha1" in $pkgs} { + lappend choices sha1 + } else { + lappend unavailable sha1 + } + set choicemsg "" + if {[llength $unavailable]} { + set choicemsg " (unavailable packages: $unavailable)" + } + set argd [punk::args::get_dict [tstr -return string { + @id -id ::textblock::use_hash + @cmd -name "textblock::use_hash" -help\ + "Hashing algorithm to use for framecache lookup. + 'none' may be slightly faster but less compact + when viewing textblock::framecache" + @values -min 0 -max 1 + hash_algorithm -choices {${$choices}} -optional 1 -help\ + "algorithm choice ${$choicemsg}" + }] $args] + variable use_hash + if {![dict exists $argd received hash_algorithm]} { + return $use_hash + } + set use_hash [dict get $argd values hash_algorithm] + } + tcl::namespace::eval class { + variable opts_table_defaults + set opts_table_defaults [tcl::dict::create\ + -title ""\ + -titlealign "left"\ + -titletransparent 0\ + -frametype "light"\ + -frametype_header ""\ + -ansibase_header ""\ + -ansibase_body ""\ + -ansibase_footer ""\ + -ansiborder_header ""\ + -ansiborder_body ""\ + -ansiborder_footer ""\ + -ansireset "\uFFeF"\ + -framelimits_header "vll vlr hlb hlt tlc trc blc brc"\ + -frametype_body ""\ + -framelimits_body "vll vlr hlb hlt tlc trc blc brc"\ + -framemap_body [list\ + topleft {} topinner {} topright {} topsolo {}\ + middleleft {} middleinner {} middleright {} middlesolo {}\ + bottomleft {} bottominner {} bottomright {} bottomsolo {}\ + onlyleft {} onlyinner {} onlyright {} onlysolo {}\ + ]\ + -framemap_header [list\ + topleft {} topinner {} topright {} topsolo {}\ + middleleft {} middleinner {} middleright {} middlesolo {}\ + bottomleft {} bottominner {} bottomright {} bottomsolo {}\ + onlyleft {} onlyinner {} onlyright {} onlysolo {}\ + ]\ + -show_edge 1\ + -show_seps 1\ + -show_hseps ""\ + -show_vseps ""\ + -show_header ""\ + -show_footer ""\ + -minwidth ""\ + -maxwidth ""\ + ] + variable opts_column_defaults + set opts_column_defaults [tcl::dict::create\ + -headers [list]\ + -header_colspans [list]\ + -footers [list]\ + -defaultvalue ""\ + -ansibase ""\ + -ansireset "\uFFEF"\ + -minwidth ""\ + -maxwidth ""\ + -blockalign centre\ + -textalign left\ + ] + #initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only + + + + #for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns) + #ie only vll,blc,hlb used for cells except top row and right column + #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) + #right cells use 'U' shape (vll,blc,hlb,brc,vlr) + #e.g for 4x4 + # C C C O + # L L L U + # L L L U + #anti-clockwise elements + set C [list hlt tlc vll blc hlb] + set O [list trc hlt tlc vll blc hlb brc vlr] + set L [list vll blc hlb] + set U [list vll blc hlb brc vlr] + set tops [list trc hlt tlc] + set lefts [list tlc vll blc] + set bottoms [list blc hlb brc] + set rights [list trc brc vlr] + + variable table_edge_parts + set table_edge_parts [tcl::dict::create\ + topleft [struct::set intersect $C [concat $tops $lefts]]\ + 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]\ + middleinner [list]\ + middleright [struct::set intersect $U $rights]\ + middlesolo [struct::set intersect $U [concat $lefts $rights]]\ + bottomleft [struct::set intersect $L [concat $lefts $bottoms]]\ + bottominner [struct::set intersect $L $bottoms]\ + bottomright [struct::set intersect $U [concat $bottoms $rights]]\ + bottomsolo [struct::set intersect $U [concat $lefts $bottoms $rights]]\ + onlyleft [struct::set intersect $C [concat $tops $lefts $bottoms]]\ + onlyinner [struct::set intersect $C [concat $tops $bottoms]]\ + onlyright [struct::set intersect $O [concat $tops $bottoms $rights]]\ + onlysolo [struct::set intersect $O [concat $tops $lefts $bottoms $rights]]\ + ] + + #for header rows - we don't consider the bottom border as part of the edge - even if table body has no rows + #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 [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 [list {*}$lefts {*}$rights]]\ + bottomleft [struct::set intersect $L $lefts]\ + bottominner [list]\ + bottomright [struct::set intersect $U $rights]\ + 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 [list {*}$tops {*}$rights]]\ + onlysolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ + ] + variable table_hseps + set table_hseps [tcl::dict::create\ + topleft [list blc hlb]\ + topinner [list blc hlb]\ + topright [list blc hlb brc]\ + topsolo [list blc hlb brc]\ + middleleft [list blc hlb]\ + middleinner [list blc hlb]\ + middleright [list blc hlb brc]\ + middlesolo [list blc hlb brc]\ + bottomleft [list]\ + bottominner [list]\ + bottomright [list]\ + bottomsolo [list]\ + onlyleft [list]\ + onlyinner [list]\ + onlyright [list]\ + onlysolo [list]\ + ] + variable table_vseps + set table_vseps [tcl::dict::create\ + topleft [list]\ + topinner [list vll tlc blc]\ + topright [list vll tlc blc]\ + topsolo [list]\ + middleleft [list]\ + middleinner [list vll tlc blc]\ + middleright [list vll tlc blc]\ + middlesolo [list]\ + bottomleft [list]\ + bottominner [list vll tlc blc]\ + bottomright [list vll tlc blc]\ + bottomsolo [list]\ + onlyleft [list]\ + onlyinner [list vll tlc blc]\ + onlyright [list vll tlc blc]\ + onlysolo [list]\ + ] + + #ensembles seem to be not compiled in safe interp + #https://core.tcl-lang.org/tcl/tktview/1095bf7f75 + #as we want textblock to be usable in safe interps - use tcl::dict::for as a partial workaround + #This at least means the script argument, especially switch statements can get compiled. + #It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp. + + #e.g $t configure -framemap_body [table_edge_map " "] + + # -- --- --- --- --- + #unused? + proc table_edge_map {char} { + variable table_edge_parts + set map [list] + tcl::dict::for {celltype parts} $table_edge_parts { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + proc table_sep_map {char} { + variable table_hseps + set map [list] + tcl::dict::for {celltype parts} $table_hseps { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + proc header_edge_map {char} { + variable header_edge_parts + set map [list] + tcl::dict::for {celltype parts} $header_edge_parts { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + # -- --- --- --- --- + + if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} { + #*** !doctools + #[subsection {Namespace textblock::class}] + #[para] class definitions + #[list_begin itemized] [comment {- textblock::class groupings -}] + # [item] + # [para] [emph {handler_classes}] + # [list_begin enumerated] + + #this makes new table objects a little faster when multiple opts specified as well as to configure + #as tables are a heavyweight thing, but handy to nest sometimes - we'll take what we can get + set topt_keys [tcl::dict::keys $::textblock::class::opts_table_defaults] + set switch_keys_valid_topts [punk::lib::lmapflat v $topt_keys {list $v -}] + set switch_keys_valid_topts [lrange $switch_keys_valid_topts 0 end-1] ;#remove last dash + + set copt_keys [tcl::dict::keys $::textblock::class::opts_column_defaults] + set switch_keys_valid_copts [punk::lib::lmapflat v $copt_keys {list $v -}] + 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. + + variable o_columndefs + variable o_columndata + variable o_columnstates + variable o_headerdefs + variable o_headerstates + + variable o_rowdefs + variable o_rowstates + + variable o_opts_table_defaults + variable o_opts_header_defaults ;# header data mostly stored in o_columndefs + variable o_opts_column_defaults + variable o_opts_row_defaults + variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap) + variable o_calculated_column_widths + variable o_column_width_algorithm + + + 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 + + + if {[llength $args] == 1} { + set args [list -title [lindex $args 0]] + } + if {[llength $args] %2 !=0} { + error "[tcl::namespace::current]::table constructor - unexpected argument count. Require single value being title, or name value pairs" + } + + set o_opts_table $o_opts_table_defaults + set o_opts_table_effective $o_opts_table_defaults + + ##todo - test with punk::lib::show_jump_tables - how? + foreach {k v} $args { + switch -- $k { + %topt_switchkeys% { + tcl::dict::set o_opts_table $k $v + } + default { + error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + } + + #foreach {k v} $args { + # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. + # if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { + # error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + # } + #} + #set o_opts_table [tcl::dict::merge $o_opts_table_defaults $args] + #my configure {*}[tcl::dict::merge $o_opts_table_defaults $args] + + set o_columndefs [tcl::dict::create] + set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row + set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly + set o_headerdefs [tcl::dict::create] ;#by header-row + set o_headerstates [tcl::dict::create] + set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight + set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data + + set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices. + set o_calculated_column_widths [list] + set o_column_width_algorithm "span" + set o_opts_header_defaults [tcl::dict::create\ + -colspans {}\ + -values {}\ + -ansibase {}\ + -ansireset "\x1b\[m"\ + -minheight 1\ + -maxheight ""\ + ] + my configure {*}$o_opts_table + } + + method width_algorithm {{alg ""}} { + if {$alg eq ""} { + return $o_column_width_algorithm + } + if {$alg ne $o_column_width_algorithm} { + #invalidate cached widths + set o_calculated_column_widths [list] + } + set o_column_width_algorithm $alg + } + method Get_seps {} { + set requested_seps [tcl::dict::get $o_opts_table -show_seps] + set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] + set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] + set seps $requested_seps + set seps_h $requested_seps_h + set seps_v $requested_seps_v + if {$requested_seps eq ""} { + if {$requested_seps_h eq ""} { + set seps_h 1 + } + if {$requested_seps_v eq ""} { + set seps_v 1 + } + } else { + if {$requested_seps_h eq ""} { + set seps_h $seps + } + if {$requested_seps_v eq ""} { + set seps_v $seps + } + } + return [tcl::dict::create horizontal $seps_h vertical $seps_v] + } + method Get_frametypes {} { + set requested_ft [tcl::dict::get $o_opts_table -frametype] + set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] + set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] + set ft $requested_ft + set ft_header $requested_ft_header + set ft_body $requested_ft_body + switch -- $requested_ft { + light { + if {$requested_ft_header eq ""} { + set ft_header heavy + } + if {$requested_ft_body eq ""} { + 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 + } + if {$requested_ft_body eq ""} { + set ft_body $requested_ft + } + } + } + return [tcl::dict::create header $ft_header body $ft_body] + } + method Set_effective_framelimits {} { + upvar ::textblock::class::opts_table_defaults tdefaults + set default_blims [tcl::dict::get $tdefaults -framelimits_body] + set default_hlims [tcl::dict::get $tdefaults -framelimits_header] + set eff_blims [tcl::dict::get $o_opts_table_effective -framelimits_body] + set eff_hlims [tcl::dict::get $o_opts_table_effective -framelimits_header] + + set requested_blims [tcl::dict::get $o_opts_table -framelimits_body] + set requested_hlims [tcl::dict::get $o_opts_table -framelimits_header] + set blims $eff_blims + set hlims $eff_hlims + switch -- $requested_blims { + "default" { + set blims $default_blims + } + default { + #set blims $requested_blims + set blims [list] + foreach lim $requested_blims { + switch -- $lim { + hl { + lappend blims hlt hlb + } + vl { + lappend blims vll vlr + } + default { + lappend blims $lim + } + } + } + set blims [lsort -unique $blims] + } + } + tcl::dict::set o_opts_table_effective -framelimits_body $blims + switch -- $requested_hlims { + "default" { + set hlims $default_hlims + } + default { + #set hlims $requested_hlims + set hlims [list] + foreach lim $requested_hlims { + switch -- $lim { + hl { + lappend hlims hlt hlb + } + vl { + lappend hlims vll vlr + } + default { + lappend hlims $lim + } + } + } + set hlims [lsort -unique $hlims] + } + } + tcl::dict::set o_opts_table_effective -framelimits_header $hlims + 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 + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [list %topt_keys%]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_opts_table $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { + tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "[tcl::namespace::current]::table configure - unexpected argument count. Require name value pairs" + } + foreach {k v} $args { + switch -- $k { + %topt_switchkeys% {} + default { + error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + #if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { + # error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + #} + } + set checked_opts [list] + foreach {k v} $args { + switch -- $k { + -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set ansi_codes [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend ansi_codes $code + } + } + set ansival [punk::ansi::codetype::sgr_merge_singles $ansi_codes] + lappend checked_opts $k $ansival + } + -frametype - -frametype_header - -frametype_body { + #frametype will raise an error if v is not a valid custom dict or one of the known predefined types such as light,heavy,double etc + lassign [textblock::frametype $v] _cat category _type ftype + lappend checked_opts $k $v + } + -framemap_body - -framemap_header { + #upvar ::textblock::class::opts_table_defaults tdefaults + #set default_bmap [tcl::dict::get $tdefaults -framemap_body] + #todo - check keys and map + if {[llength $v] == 1} { + if {$v eq "default"} { + upvar ::textblock::class::opts_table_defaults tdefaults + set default_map [tcl::dict::get $tdefaults $k] + lappend checked_opts $k $default_map + } else { + error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}" + } + } else { + #safe jumptable test + #dict for {subk subv} $v {} + foreach {subk subv} $v { + switch -- $subk { + topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} + default { + error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" + } + } + #safe jumptable test + #dict for {seg subst} $subv {} + foreach {seg subst} $subv { + switch -- $seg { + hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {} + default { + error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}" + } + } + } + + } + lappend checked_opts $k $v + } + + } + -framelimits_body - -framelimits_header { + set specific_framelimits [list] + foreach fl $v { + switch -- $fl { + "default" { + lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr + } + hl { + lappend specific_framelimits hlt hlb + } + vl { + lappend specific_framelimits vll vlr + } + hlt - hlb - vll - vlr - trc - tlc - blc - brc { + lappend specific_framelimits $fl + } + default { + error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)" + } + } + } + lappend checked_opts $k $specific_framelimits + } + -ansireset { + if {$v eq "\uFFEF"} { + set RST "\x1b\[m" ;#[a] + lappend checked_opts $k $RST + } else { + error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -show_hseps { + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + lappend checked_opts $k $v + #these don't affect column width calculations + } + -show_edge { + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + lappend checked_opts $k $v + #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + } + -show_vseps { + #we allow empty string - so don't use -strict boolean check + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + #affects width calculations + set o_calculated_column_widths [list] + lappend checked_opts $k $v + } + -minwidth - -maxwidth { + set o_calculated_column_widths [list] + lappend checked_opts $k $v + } + default { + lappend checked_opts $k $v + } + } + } + #all options checked - ok to update o_opts_table and o_opts_table_effective + + #set o_opts_table [tcl::dict::merge $o_opts_table $checked_opts] + foreach {k v} $args { + switch -- $k { + -framemap_header - -framemap_body { + #framemaps don't require setting every key to update. + #e.g configure -framemaps {topleft } + #needs to merge with existing unspecified keys such as topright middleleft etc. + if {$v eq "default"} { + tcl::dict::set o_opts_table $k default + } else { + if {[tcl::dict::get $o_opts_table $k] eq "default"} { + tcl::dict::set o_opts_table $k $v + } else { + tcl::dict::set o_opts_table $k [tcl::dict::merge [tcl::dict::get $o_opts_table $k] $v] + } + } + } + -title { + set twidth [punk::ansi::printing_length $v] + if {[my width] < [expr {$twidth+2}]} { + set o_calculated_column_widths [list] + tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] + } + tcl::dict::set o_opts_table -title $v + } + default { + tcl::dict::set o_opts_table $k $v + } + } + } + #use values from checked_opts for the effective opts + #safe jumptable test + #dict for {k v} $checked_opts {} + #foreach {k v} $checked_opts {} + tcl::dict::for {k v} $checked_opts { + switch -- $k { + -framemap_body - -framemap_header { + set existing [tcl::dict::get $o_opts_table_effective $k] + #set updated $existing + #dict for {subk subv} $v { + # tcl::dict::set updated $subk $subv + #} + #tcl::dict::set o_opts_table_effective $k $updated + tcl::dict::set o_opts_table_effective $k [tcl::dict::merge $existing $v] + } + -framelimits_body - -framelimits_header { + #my Set_effective_framelimits + tcl::dict::set o_opts_table_effective $k $v + } + default { + tcl::dict::set o_opts_table_effective $k $v + } + } + } + #ansireset exception + tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] + return $o_opts_table + } + + #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] + if {$table_colcount == 0} { + for {set c 0} {$c < $matrix_colcount} {incr c} { + my add_column -headers "" + } + } + set table_colcount [my column_count] + if {$table_colcount != $matrix_colcount} { + error "textblock::table::printmatrix column count of table doesn't match column count of matrix" + } + if {[my row_count] > 0} { + my row_clear + } + for {set r 0} {$r < $matrix_rowcount} {incr r} { + my add_row [$matrix get row $r] + } + 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 { + set m [struct::matrix $cmd] + } + $m add columns [tcl::dict::size $o_columndata] + $m add rows [tcl::dict::size $o_rowdefs] + tcl::dict::for {k v} $o_columndata { + $m set column $k $v + } + return $m + } + method add_column {args} { + #*** !doctools + #[call class::table [method add_column] [arg args]] + + + if {[llength $args] %2 != 0} { + error "[tcl::namespace::current]::table::add_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" + } + set opts $o_opts_column_defaults + foreach {k v} $args { + switch -- $k { + %copt_switchkeys% { + tcl::dict::set opts $k $v + } + default { + error "[tcl::namespace::current]::table::add_column unknown option '$k'. Known options: %copt_keys%" + } + } + } + set colcount [tcl::dict::size $o_columndefs] + + + tcl::dict::set o_columndata $colcount [list] + #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists + tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists + + + tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] + set prev_calculated_column_widths $o_calculated_column_widths + if {[catch { + my configure_column $colcount {*}$opts + } errMsg]} { + #configure failed - ensure o_columndata and o_columndefs entries are removed + tcl::dict::unset o_columndata $colcount + tcl::dict::unset o_columndefs $colcount + tcl::dict::unset o_columnstates $colcount + #undo cache invalidation + set o_calculated_column_widths $prev_calculated_column_widths + error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" + } + #any add_column that succeeds should invalidate the calculated column widths + set o_calculated_column_widths [list] + set numrows [my row_count] + if {$numrows > 0} { + #fill column with default values + #puts ">>> adding default values for column $colcount" + set dval [tcl::dict::get $opts -defaultvalue] + set width [textblock::width $dval] + tcl::dict::set o_columndata $colcount [lrepeat $numrows $dval] + tcl::dict::set o_columnstates $colcount maxwidthbodyseen $width + tcl::dict::set o_columnstates $colcount minwidthbodyseen $width + } + 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" + } + if {![llength $args]} { + return [tcl::dict::get $o_columndefs $cidx] + } else { + if {[llength $args] == 1} { + if {[lindex $args 0] in [list %copt_keys%]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_columndefs $cidx $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + } else { + error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values %copt_keys%" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" + } + foreach {k v} $args { + switch -- $k { + %copt_switchkeys% {} + default { + error "[tcl::namespace::current]::table configure_column unknown option '$k'. Known options: %copt_keys%" + } + } + } + set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state + + set hstates $o_headerstates ;#operate on a copy + set colstate [tcl::dict::get $o_columnstates $cidx] + set args_got_headers 0 + set args_got_header_colspans 0 + foreach {k v} $args { + switch -- $k { + -headers { + set args_got_headers 1 + set i 0 + set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. + foreach hdr $v { + set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns + #set this_header_height [textblock::height $hdr] + lassign [textblock::size $hdr] _w this_header_width _h this_header_height + + if {$this_header_height >= $currentmax} { + tcl::dict::set hstates $i maxheightseen $this_header_height + } else { + tcl::dict::set hstates $i maxheightseen $currentmax + } + if {$this_header_width >= $maxseen} { + set maxseen $this_header_width + } + #if {$this_header_width > [tcl::dict::get $colstate maxwidthheaderseen]} { + # tcl::dict::set colstate maxwidthheaderseen $this_header_width + #} + incr i + } + tcl::dict::set colstate maxwidthheaderseen $maxseen + #review - we could avoid some recalcs if we check current width range compared to previous + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -header_colspans { + set args_got_header_colspans 1 + #check columns to left to make sure each new colspan for this column makes sense in the overall context + #user may have to adjust colspans in order left to right to avoid these check errors + #note that 'any' represents span all up to the next non-zero defined colspan. + set cspans [my header_colspans] + set h 0 + if {[llength $v] > [tcl::dict::size $cspans]} { + error "configure_column $cidx -header_colspans. Only [tcl::dict::size $cspans] headers exist. Too many values supplied" + } + foreach s $v { + if {$cidx == 0} { + if {[tcl::string::is integer -strict $s]} { + if {$s < 1} { + error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'any' or a positive integer" + } + } else { + if {$s ne "any" && $s ne ""} { + error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" + } + } + } else { + #if {![tcl::string::is integer -strict $s]} { + # if {$s ne "any" && $s ne ""} { + # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" + # } + #} else { + set header_spans [tcl::dict::get $cspans $h] + set remaining [lindex $header_spans 0] + if {$remaining ne "any"} { + incr remaining -1 + } + #look at spans defined for previous cols + #we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption + for {set c 0} {$c < $cidx} {incr c} { + set span [lindex $header_spans $c] + if {$span eq "any"} { + set remaining "any" + } else { + if {$remaining eq "any"} { + if {$span ne "0"} { + #a previous column has ended the 'any' span + set remaining [expr {$span -1}] + } + } else { + if {$span eq "0"} { + incr remaining -1 + } else { + set remaining [expr {$span -1}] + } + #allow to go negative + } + } + } + if {$remaining eq "any"} { + #any int >0 ok - what about 'any' immediately following any? + } else { + if {$remaining > 0} { + if {$s ne "0" && $s ne ""} { + error "configure_column $cidx -header_colspans bad span $s for header '$h'. Remaining span is '$remaining' - so a zero colspan is required" + } + } else { + if {$s == 0} { + error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" + } + } + } + #} + } + incr h + } + #todo - avoid recalc if no change + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -minwidth { + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -maxwidth { + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set col_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend col_ansibase_items $code + } + } + set col_ansibase [punk::ansi::codetype::sgr_merge_singles $col_ansibase_items] + tcl::dict::set checked_opts $k $col_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + tcl::dict::set checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -blockalign - -textalign { + switch -- $v { + left - right { + tcl::dict::set checked_opts $k $v + } + centre - centre { + tcl::dict::set checked_opts $k centre + } + } + } + default { + tcl::dict::set checked_opts $k $v + } + } + } + #args checked - ok to update headerstates, headerdefs and columndefs and columnstates + tcl::dict::set o_columndefs $cidx $checked_opts + set o_headerstates $hstates + dict for {hidx hstate} $hstates { + #configure_header + if {![dict exists $o_headerdefs $hidx]} { + #remove calculated members -values -colspans + set hdefaults [dict remove $o_opts_header_defaults -values -colspans] + dict set o_headerdefs $hidx $hdefaults + } + } + + tcl::dict::set o_columnstates $cidx $colstate + + if {$args_got_headers} { + #if the headerlist length for this column has shrunk,and it was the longest - we may now have excess entries in o_headerstates + set zero_heights [list] + tcl::dict::for {hidx _v} $o_headerstates { + #pass empty string for exclude_column so we don't exclude our own column + if {[my header_height_calc $hidx ""] == 0} { + lappend zero_heights $hidx + } + } + foreach zidx $zero_heights { + tcl::dict::unset o_headerstates $zidx + } + } + if {$args_got_headers || $args_got_header_colspans} { + #check and adjust header_colspans for all columns + + } + + return [tcl::dict::get $o_columndefs $cidx] + } + } + + 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 {} { + set max_headers 0 + tcl::dict::for {k cdef} $o_columndefs { + set num_headers [llength [tcl::dict::get $cdef -headers]] + set max_headers [expr {max($max_headers,$num_headers)}] + } + 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] + } + + #review - use maxwidth (considering colspans) of each column to determine height after wrapping + # -need to consider whether vertical expansion allowed / maxheight? + method header_height_calc {header_index {exclude_column ""}} { + set dataheight 0 + if {$exclude_column eq ""} { + set exclude_colidx "" + } else { + set exclude_colidx [lindex [tcl::dict::keys $o_columndefs] $exclude_column] + } + tcl::dict::for {cidx cdef} $o_columndefs { + if {$exclude_colidx == $cidx} { + continue + } + set headerlist [tcl::dict::get $cdef -headers] + if {$header_index < [llength $headerlist]} { + set this_height [textblock::height [lindex $headerlist $header_index]] + set dataheight [expr {max($dataheight,$this_height)}] + } + } + return $dataheight + } + + #return a dict keyed on header index with values representing colspans + #e.g + # 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] + tcl::dict::for {cidx cdef} $o_columndefs { + set headerlist [tcl::dict::get $cdef -headers] + set colspans_for_column [tcl::dict::get $cdef -header_colspans] + for {set h 0} {$h < $num_headers} {incr h} { + set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] + set defined_span [lindex $colspans_for_column $h] + set i 0 + set spanremaining [lindex $headerspans 0] + if {$spanremaining ne "any"} { + if {$spanremaining eq ""} { + set spanremaining 1 + } + incr spanremaining -1 + } + foreach s $headerspans { + if {$s eq "any"} { + set spanremaining "any" + } elseif {$s == 0} { + if {$spanremaining ne "any"} { + incr spanremaining -1 + } + } else { + set spanremaining [expr {$s - 1}] + } + incr i + } + if {$defined_span eq ""} { + if {$spanremaining eq "0"} { + lappend headerspans 1 + } else { + #"any" or an integer + lappend headerspans 0 + } + } else { + lappend headerspans $defined_span + } + tcl::dict::set colspans_by_header $h $headerspans + } + } + return $colspans_by_header + } + + #e.g + # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 any 1} 3 {any 0 0 1} + #convert to + # 0 {4 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} + method header_colspans_numeric {} { + set hcolspans [my header_colspans] + if {![tcl::dict::size $hcolspans]} { + return + } + set numcols [llength [tcl::dict::get $hcolspans 0]] ;#assert: all are the same + tcl::dict::for {h spans} $hcolspans { + set c 0 ;#column index + foreach s $spans { + if {$s eq "any"} { + set spanlen 1 + for {set i [expr {$c+1}]} {$i < $numcols} {incr i} { + #next 'any' or non-zero ends an 'any' span + if {[lindex $spans $i] ne "0"} { + break + } + incr spanlen + } + #overwrite the 'any' with it's actual span + set modified_spans [dict get $hcolspans $h] + lset modified_spans $c $spanlen + dict set hcolspans $h $modified_spans + } + incr c + } + } + return $hcolspans + } + + method configure_header {index_expression args} { + #*** !doctools + #[call class::table [method configure_header]] + #[para] - configure header row-wise + + #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} + set num_headers [my header_count_calc] + set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression] + if {$hidx eq ""} { + error "textblock::table::configure_header - no header row defined at index '$index_expression'." + } + if {$hidx > $num_headers -1} { + #assert - shouldn't happen + error "textblock::table::configure_header error headerstates data is out of sync" + } + + if {![llength $args]} { + set colspans_by_header [my header_colspans] + set result [tcl::dict::create] + tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] + set header_row_items [list] + tcl::dict::for {cidx cdef} $o_columndefs { + set colheaders [tcl::dict::get $cdef -headers] + set relevant_header [lindex $colheaders $hidx] + #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + } + tcl::dict::set result -values $header_row_items + + #review - ensure always a headerdef record for each header? + if {[tcl::dict::exists $o_headerdefs $hidx]} { + set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]] + } else { + #warn for now + puts stderr "no headerdef record for header $hidx" + } + return $result + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [tcl::dict::keys $o_opts_header_defaults]} { + #query single option + set k [lindex $args 0] + #set val [tcl::dict::get $o_rowdefs $ridx $k] + + set infodict [tcl::dict::create] + #todo + # -blockalignments and -textalignments lists + # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} + #if there is a value it overrides alignments specified on the column + switch -- $k { + -values { + set header_row_items [list] + tcl::dict::for {cidx cdef} $o_columndefs { + set colheaders [tcl::dict::get $cdef -headers] + set relevant_header [lindex $colheaders $hidx] + #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + + } + set val $header_row_items + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + } + -colspans { + set colspans_by_header [my header_colspans] + set result [tcl::dict::create] + set val [tcl::dict::get $colspans_by_header $hidx] + #ansireset not required + set returndict [tcl::dict::create option $k value $val] + } + -ansibase { + set val ??? + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_header_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_header_defaults]" + } + foreach {k v} $args { + if {$k ni [tcl::dict::keys $o_opts_header_defaults]} { + error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_header_defaults]" + } + } + + set checked_opts [list] + #safe jumptable test + #dict for {k v} $args {} + foreach {k v} $args { + switch -- $k { + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set header_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend header_ansibase_items $code + } + } + set header_ansibase [punk::ansi::codetype::sgr_merge_singles $header_ansibase_items] + lappend checked_opts $k $header_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + lappend checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -values { + if {[llength $v] > [tcl::dict::size $o_columndefs]} { + error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" + } + lappend checked_opts $k $v + } + -colspans { + set numcols [tcl::dict::size $o_columndefs] + if {[llength $v] > $numcols} { + error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" + } + if {[llength $v] < $numcols} { + puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." + puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" + } + if {[llength $v]} { + set firstspan [lindex $v 0] + set first_is_ok 0 + if {$firstspan eq "any"} { + set first_is_ok 1 + } elseif {[tcl::string::is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} { + set first_is_ok 1 + } + if {!$first_is_ok} { + error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" + } + #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) + set remaining $firstspan + if {$remaining ne "any"} { + incr remaining -1 + } + set spanview $v + set sidx 1 + #because we allow 'any' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'any' first + foreach span [lrange $v 1 end] { + if {$remaining eq "any"} { + if {$span eq "any"} { + set remaining "any" + } elseif {$span > 0} { + #ok to reset to higher val immediately or after an any and any number of following zeros + if {$span > ($numcols - $sidx)} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" + } + set remaining $span + incr remaining -1 + } else { + #zero following an any - leave remaining as any + } + } else { + if {$span eq "0"} { + if {$remaining eq "0"} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" + } else { + incr remaining -1 + } + } else { + if {$remaining eq "0"} { + #ok for new span value of any or > 0 + if {$span ne "any" && $span > ($numcols - $sidx)} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" + } + set remaining $span + if {$remaining ne "any"} { + incr remaining -1 + } + } else { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" + } + } + } + incr sidx + } + } + #empty -colspans list should be ok + + #error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now" + lappend checked_opts $k $v + } + default { + lappend checked_opts $k $v + } + } + } + + #configured opts all good + #safe jumptable test + #dict for {k v} $checked_opts {} + #foreach {k v} $checked_opts {} + + # headerdefs excludes -values and -colspans + set update_hdefs [tcl::dict::get $o_headerdefs $hidx] + + tcl::dict::for {k v} $checked_opts { + switch -- $k { + -values { + set c 0 + foreach hval $v { + #retrieve -headers from relevant col, insert at header index, and write back. + set thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers] + set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}] + if {$missing > 0} { + lappend thiscol_headers_vertical {*}[lrepeat $missing ""] + } + lset thiscol_headers_vertical $hidx $hval + tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical + #invalidate column width cache + set o_calculated_column_widths [list] + # -- -- -- -- -- -- + #also update maxwidthseen & maxheightseen + set i 0 + set maxwidthseen 0 + #set maxheightseen 0 + foreach hdr $thiscol_headers_vertical { + lassign [textblock::size $hdr] _w this_header_width _h this_header_height + set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0] + if {$this_header_height >= $maxheightseen} { + tcl::dict::set o_headerstates $i maxheightseen $this_header_height + } else { + tcl::dict::set o_headerstates $i maxheightseen $maxheightseen + } + if {$this_header_width >= $maxwidthseen} { + set maxwidthseen $this_header_width + } + incr i + } + tcl::dict::set o_columnstates $c maxwidthheaderseen $maxwidthseen + # -- -- -- -- -- -- + incr c + } + } + -colspans { + #sequence has been verified above - we need to split it and store across columns + set c 0 ;#column index + foreach span $v { + set colspans [tcl::dict::get $o_columndefs $c -header_colspans] + if {$hidx > [llength $colspans]-1} { + set colspans_by_header [my header_colspans] + #puts ">>>>>?$colspans_by_header" + #we are allowed to lset only one beyond the current length to append + #but there may be even less or no entries present in a column + # - the ability to underspecify and calculate the missing values makes setting the values complicated. + #use the header_colspans calculation to update only those entries necessary + set spanlist [list] + for {set h 0} {$h < $hidx} {incr h} { + set cspans [tcl::dict::get $colspans_by_header $h] + set requiredval [lindex $cspans $c] + lappend spanlist $requiredval + } + tcl::dict::set o_columndefs $c -header_colspans $spanlist + + set colspans [tcl::dict::get $o_columndefs $c -header_colspans] + } + + lset colspans $hidx $span + tcl::dict::set o_columndefs $c -header_colspans $colspans + incr c + } + } + default { + dict set update_hdefs $k $v + } + } + } + set opt_minh [tcl::dict::get $update_hdefs -minheight] + set opt_maxh [tcl::dict::get $update_hdefs -maxheight] + + #todo - allow zero values to hide/collapse + # - see also configure_row + if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { + error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" + } + if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { + error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" + } + if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { + error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" + } + + #set o_headerstate $hidx -minheight? -maxheight? ??? + tcl::dict::set o_headerdefs $hidx $update_hdefs + } + + method add_row {valuelist args} { + #*** !doctools + #[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 + append msg "rowdata: $valuelist" + error $msg + } + if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { + error "add_row - no values supplied, and no columns defined, so cannot use default column values" + } + + set defaults [tcl::dict::create\ + -minheight 1\ + -maxheight ""\ + -ansibase ""\ + -ansireset "\uFFEF"\ + ] + set o_opts_row_defaults $defaults + + if {[llength $args] %2 !=0} { + error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" + } + #safe jumptable test + #dict for {k v} $args {} + foreach {k v} $args { + switch -- $k { + -minheight - -maxheight - -ansibase - -ansireset {} + default { + error "Invalid option '$k' Known options: [tcl::dict::keys $defaults] (-ansireset is read-only)" + } + } + } + set opts [tcl::dict::merge $defaults $args] + + set auto_columns 0 + if {[tcl::dict::size $o_columndefs] == 0} { + set auto_columns 1 + #no columns defined - auto define with defaults for each column in first supplied row + #auto define columns only valid if no existing columns + #the autocolumns must be added before configure_row - but if configure_row fails - we need to remove them! + foreach el $valuelist { + my add_column + } + } else { + if {![llength $valuelist]} { + tcl::dict::for {k coldef} $o_columndefs { + lappend valuelist [tcl::dict::get $coldef -defaultvalue] + } + } + } + set rowcount [tcl::dict::size $o_rowdefs] + tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure + + if {[catch { + my configure_row $rowcount {*}$opts + } errMsg]} { + #undo anything we saved before configure_row + tcl::dict::unset o_rowdefs $rowcount + #remove auto_columns + if {$auto_columns} { + set o_columndata [tcl::dict::create] + set o_columndefs [tcl::dict::create] + set o_columnstate [tcl::dict::create] + } + error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" + } + + + set c 0 + set max_height_seen 1 + foreach v $valuelist { + set prev_maxwidth [tcl::dict::get $o_columnstates $c maxwidthbodyseen] + set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] + + tcl::dict::lappend o_columndata $c $v + lassign [textblock::size_as_list $v] valwidth valheight + if {$valheight > $max_height_seen} { + set max_height_seen $valheight + } + if {$valwidth > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { + tcl::dict::set o_columnstates $c maxwidthbodyseen $valwidth + } + 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} { + #invalidate calculated column width cache if any new value was outside the previous range of widths + set o_calculated_column_widths [list] + } + incr c + } + + set opt_maxh [tcl::dict::get $o_rowdefs $rowcount -maxheight] + if {$opt_maxh ne ""} { + tcl::dict::set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}] + } else { + tcl::dict::set o_rowstates $rowcount -maxheight $max_height_seen + } + + 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" + } + if {![llength $args]} { + return [tcl::dict::get $o_rowdefs $ridx] + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [tcl::dict::keys $o_opts_row_defaults]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_rowdefs $ridx $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_row_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_row_defaults]" + } + foreach {k v} $args { + if {$k ni [tcl::dict::keys $o_opts_row_defaults]} { + error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_row_defaults]" + } + } + set checked_opts [list] + foreach {k v} $args { + switch -- $k { + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set row_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend row_ansibase_items $code + } + } + set row_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] + lappend checked_opts $k $row_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + lappend checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_row -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + default { + lappend checked_opts $k $v + } + } + } + + set current_opts [tcl::dict::get $o_rowdefs $ridx] + set opts [tcl::dict::merge $current_opts $checked_opts] + + #check minheight and maxheight together + set opt_minh [tcl::dict::get $opts -minheight] + set opt_maxh [tcl::dict::get $opts -maxheight] + + #todo - allow zero values to hide/collapse rows as is possible with columns + if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { + error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" + } + if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { + error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" + } + if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { + error "[tcl::namespace::current]::table::configure_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" + } + tcl::dict::set o_rowstates $ridx -minheight $opt_minh + + + 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 + tcl::dict::for {cidx records} $o_columndata { + tcl::dict::set o_columndata $cidx [list] + #reset only the body fields in o_columnstates + tcl::dict::set o_columnstates $cidx minwidthbodyseen 0 + tcl::dict::set o_columnstates $cidx maxwidthbodyseen 0 + } + 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] + set o_columnstates [tcl::dict::create] + } + + + + #method Get_columns_by_name {namematch_list} { + #} + + #specify range with x..y + method Get_columns_by_indices {index_list} { + foreach spec $index_list { + if {[tcl::string::is integer -strict $c]} { + set colidx $c + } else { + tcl::dict::for {colidx coldef} $o_columndefs { + #if {[tcl::string::match x x]} {} + } + } + } + } + method Get_boxlimits_and_joins {position fname_body} { + #fname_body will be "custom" or one of the predefined types light,heavy etc + switch -- $position { + left { + return [tcl::dict::create \ + boxlimits [list hlb blc vll]\ + boxlimits_top [list hlb blc vll hlt tlc]\ + joins [list down]\ + bodyjoins [list down-$fname_body]\ + ] + } + inner { + return [tcl::dict::create \ + boxlimits [list hlb blc vll]\ + boxlimits_top [list hlb blc vll hlt tlc]\ + joins [list down left]\ + bodyjoins [list left down-$fname_body] + ] + } + right { + return [tcl::dict::create \ + boxlimits [list hlb blc vll vlr brc]\ + boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ + joins [list down left]\ + bodyjoins [list left down-$fname_body]\ + ] + } + solo { + return [tcl::dict::create \ + boxlimits [list hlb blc vll vlr brc]\ + boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ + joins [list down]\ + bodyjoins [list down-$fname_body]\ + ] + } + default { + error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo" + } + } + } + method Get_boxlimits_and_joins1 {position fname_body} { + #fname_body will be "custom" or one of the predefined types light,heavy etc + switch -- $position { + left { + #set header_boxlimits {hlb hlt tlc blc vll} + set header_body_joins [list down-$fname_body] + set boxlimits_position [list hlb blc vll] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] + set boxlimits_toprow [list hlb blc vll hlt tlc] + set joins [list down] + } + inner { + #set header_boxlimits {hlb hlt tlc blc vll} + set header_body_joins [list left down-$fname_body] + set boxlimits_position [list hlb blc vll] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] + set boxlimits_toprow [list hlb blc vll hlt tlc] + set joins [list down left] + } + right { + #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} + set header_body_joins [list left down-$fname_body] + set boxlimits_position [list hlb blc vll vlr brc] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] + set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] + set joins [list down left] + } + solo { + #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} + set header_body_joins [list down-$fname_body] + set boxlimits_position [list hlb blc vll vlr brc] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] + set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] + set joins [list down] + } + } + return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ] + } + method get_column_by_index {index_expression args} { + #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" + #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. + set opts [tcl::dict::create\ + -position "inner"\ + -return "string"\ + ] + foreach {k v} $args { + switch -- $k { + -position - -return { + tcl::dict::set opts $k $v + } + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid option '$k'. Known options [tcl::dict::keys $opts]" + } + } + } + set opt_posn [tcl::dict::get $opts -position] + set opt_return [tcl::dict::get $opts -return] + + switch -- $opt_posn { + left - inner - right - solo {} + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo]" + } + } + switch -- $opt_return { + string - dict {} + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_return' for -return. Valid values: string dict" + } + } + + set columninfo [my get_column_cells_by_index $index_expression] + set header_list [tcl::dict::get $columninfo headers] + #puts "===== header_list: $header_list" + set cells [tcl::dict::get $columninfo cells] + + set topt_show_header [tcl::dict::get $o_opts_table -show_header] + if {$topt_show_header eq ""} { + set allheaders 0 + set all_cols [tcl::dict::keys $o_columndefs] + foreach c $all_cols { + incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] + } + if {$allheaders == 0} { + set do_show_header 0 + } else { + set do_show_header 1 + } + } else { + set do_show_header $topt_show_header + } + set topt_show_footer [tcl::dict::get $o_opts_table -show_footer] + + + set output "" + set part_header "" + set part_body "" + set part_footer "" + + set boxlimits "" + set joins "" + set header_boxlimits [list] + set header_body_joins [list] + + + set ftypes [my Get_frametypes] + set ftype_body [tcl::dict::get $ftypes body] + if {[llength $ftype_body] >= 2} { + set fname_body "custom" + } else { + set fname_body $ftype_body + } + set ftype_header [tcl::dict::get $ftypes header] + if {[llength $ftype_header] >= 2} { + set fname_header "custom" + } else { + set fname_header $ftype_header + } + + set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] + set header_body_joins [tcl::dict::get $limj bodyjoins] + set joins [tcl::dict::get $limj joins] + set boxlimits_position [tcl::dict::get $limj boxlimits] + set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] + #use struct::set instead of simple for loop - will be faster at least when critcl available + set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] + set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] + set header_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_position] + set header_boxlimits_toprow [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_toprow] + + set fmap [tcl::dict::get $o_opts_table_effective -framemap_body] + set hmap [tcl::dict::get $o_opts_table_effective -framemap_header] + + #if {![tcl::dict::get $o_opts_table -show_edge]} { + # set body_edgemap [textblock::class::table_edge_map ""] + # dict for {k v} $fmap { + # #tcl::dict::set fmap $k [tcl::dict::merge $v [tcl::dict::get $body_edgemap $k]] + # } + # set header_edgemap [textblock::class::header_edge_map ""] + # dict for {k v} $hmap { + # #tcl::dict::set hmap $k [tcl::dict::merge $v [tcl::dict::get $header_edgemap $k]] + # } + #} + set sep_elements_horizontal $::textblock::class::table_hseps + set sep_elements_vertical $::textblock::class::table_vseps + + set topmap [tcl::dict::get $fmap top$opt_posn] + set botmap [tcl::dict::get $fmap bottom$opt_posn] + set midmap [tcl::dict::get $fmap middle$opt_posn] + set onlymap [tcl::dict::get $fmap only$opt_posn] + + set hdrmap [tcl::dict::get $hmap only${opt_posn}] + + set topseps_h [tcl::dict::get $sep_elements_horizontal top$opt_posn] + set midseps_h [tcl::dict::get $sep_elements_horizontal middle$opt_posn] + set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] + set midseps_v [tcl::dict::get $sep_elements_vertical middle$opt_posn] + set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] + set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] + + #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway + set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] + + lassign [my Get_seps] _h show_seps_h _v show_seps_v + set return_headerheight 0 + set return_headerwidth 0 + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + + set colwidth [my column_width $cidx] + + set col_blockalign [tcl::dict::get $o_columndefs $cidx -blockalign] + + if {$do_show_header} { + #puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap" + set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure + set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] + if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { + set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] + set ansiborder_final $ansibase_header$ansiborder_header$extrabg + } else { + set ansiborder_final $ansibase_header$ansiborder_header + } + set RST [punk::ansi::a] + + + set hcolwidth $colwidth + #set hcolwidth [my column_width_configured $cidx] + set hcell_line_blank [tcl::string::repeat " " $hcolwidth] + + set all_colspans [my header_colspans_numeric] + + #put our framedef calls together + set fdef_header [textblock::framedef $ftype_header] + set framedef_leftbox [textblock::framedef -joins left $ftype_header] + set framedef_headerdown_same [textblock::framedef -joins {down} $ftype_header] + set framedef_headerdown_body [textblock::framedef -joins [list down-$fname_body] $ftype_header] + #default span_extend_map - used as base to customise with specific joins + set span_extend_map [tcl::dict::create \ + vll " "\ + tlc [tcl::dict::get $fdef_header hlt]\ + blc [tcl::dict::get $fdef_header hlb]\ + ] + + + #used for colspan-zero header frames + set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test + + set hrow 0 + set hmax [expr {[llength $header_list] -1}] + foreach header $header_list { + set headerspans [tcl::dict::get $all_colspans $hrow] + set this_span [lindex $headerspans $cidx] + #set hval $ansibase_header$header ;#no reset + set hval $header + set rowh [my header_height $hrow] + + if {$hrow == 0} { + set hlims $header_boxlimits_toprow + set rowpos "top" + if {$hrow == $hmax} { + set rowpos "only" + } + } else { + set hlims $header_boxlimits + set rowpos "middle" + if {$hrow == $hmax} { + set rowpos "bottom" + } + } + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {$hrow == $hmax} { + set header_joins $header_body_joins + } else { + set header_joins $joins + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + } + #puts ">>> headerspans: $headerspans cidx: $cidx" + + #if {$this_span eq "any" || $this_span > 0} {} + #changed to processing only numeric colspans + + if {$this_span > 0} { + set startmap [tcl::dict::get $hmap $rowpos${opt_posn}] + #look at spans in header below to determine joins required at blc + if {$show_seps_v} { + if {[tcl::dict::exists $all_colspans [expr {$hrow+1}]]} { + set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] + set spanbelow [lindex $next_spanlist $cidx] + if {$spanbelow == 0} { + #we don't want a down-join for blc - use a framedef with only left joins + tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] + } + } else { + set next_spanlist [list] + } + } + + #supporting wrapping in headers might be a step too difficult for little payoff. + #we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib) + #The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex. + #May be better to require user to pre-wrap as needed + ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] + + #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used + #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) + + # -width is always +2 - as the boxlimits take into account show_vseps and show_edge + #set header_cell_startspan [textblock::frame -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 $hval\ + # ] + + if {$this_span == 1} { + #write the actual value now + set cellcontents $hval + } else { + #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 -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\ + ] + + if {$this_span != 1} { + #puts "===>\n$header_cell_startspan\n<===" + set spanned_parts [list $header_cell_startspan] + #assert this_span == "any" or >1 ie a header that spans other columns + #therefore more parts to append + #set remaining_cols [lrange [tcl::dict::keys $o_columndefs] $cidx end] + set remaining_spans [lrange $headerspans $cidx+1 end] + set spanval [join $remaining_spans ""] ;#so we can test for all zeros + set spans_to_rhs 0 + if {[expr {$spanval}] == 0} { + #puts stderr "SPANS TO RHS" + set spans_to_rhs 1 + } + + #puts ">> remaining_spans: $remaining_spans" + set spancol [expr {$cidx + 1}] + set h_lines [lrepeat $rowh ""] + set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + + + + set last [expr {[llength $remaining_spans] -1}] + set i 0 + foreach s $remaining_spans { + if {$s == 0} { + if {$i == $last} { + set next_posn right + #set next_posn inner + } else { + set next_posn inner + } + + set next_headerseps_v [tcl::dict::get $sep_elements_vertical top$next_posn] ;#static top ok + + set limj [my Get_boxlimits_and_joins $next_posn $fname_body] + set span_joins_body [tcl::dict::get $limj bodyjoins] + set span_joins [tcl::dict::get $limj joins] + set span_boxlimits [tcl::dict::get $limj boxlimits] + set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] + #use struct::set instead of simple for loop - will be faster at least when critcl available + #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] + #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] + set header_span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits] + set header_span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits_top] + if {$hrow == 0} { + set hlims $header_span_boxlimits_top + } else { + set hlims $header_span_boxlimits + } + + set this_span_map $span_extend_map + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $next_headerseps_v] + } else { + if {[llength $next_spanlist]} { + set spanbelow [lindex $next_spanlist $spancol] + if {$spanbelow != 0} { + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype + } + } else { + #join to body + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype + } + } + + if {$hrow == $hmax} { + set header_joins $span_joins_body + } else { + set header_joins $span_joins + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] + } + + set contentwidth [my column_width $spancol] + set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [tcl::dict::get $ftypes header]\ + -ansibase $ansibase_header -ansiborder $ansiborder_final\ + -boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\ + ] + lappend spanned_parts $header_cell + } else { + break + } + incr spancol + incr i + } + + #JMN + #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic + set spanned_frame [textblock::join_basic -- {*}$spanned_parts] + + if {$spans_to_rhs} { + if {$cidx == 0} { + set fake_posn solo + } else { + set fake_posn right + } + set x_limj [my Get_boxlimits_and_joins $fake_posn $fname_body] + if {$hrow == 0} { + set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] + } else { + set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] + } + } else { + if {$hrow == 0} { + set hlims $header_boxlimits_toprow + } else { + set hlims $header_boxlimits + } + } + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + if {$spans_to_rhs} { + #assert fake_posn has been set above based on cidx and spans_to_rhs + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts ${rowpos}$fake_posn] ] + } else { + #use the edge_parts corresponding to the column being written to ie use opt_posn + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + } + } + + set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements + #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 -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]" + #puts "==>hval:'[ansistring VIEW $hval]'" + #set spanned_frame [overtype::renderspace -transparent 1 $spanned_frame $hblock] + + #spanned values default left - todo make configurable + + #TODO + #consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span + #we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes? + #this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span. + #(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned) + + set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] + #POTENTIAL BUG (fixed with spans_to_rhs above) + #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) + #we need to shift 1 to the left when doing our overtype with blockalign right + #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge + #(even though the column position may be left or inner) + + + + } else { + #this_span == 1 + set spanned_frame [textblock::join_basic -- $header_cell_startspan] + } + + + append part_header $spanned_frame + append part_header \n + } else { + #zero span header directly in this column ie one that is being colspanned by some column to our left + #previous col will already have built lines for this in it's own header rhs overhang + #we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent. + + #set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1] + + #if there are no header elements above then we will need a minimum of the column width + #may be extended to the widest portion of the header in the loop below + set padwidth [my column_width $cidx] + + + #under assumption we are building table using L frame method and that horizontal borders are only ever 1 high + # - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc + #avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 ) + if 0 { + #breaks -show_edge 0 + if {$rowpos eq "top" && [tcl::dict::get $o_opts_table -show_edge]} { + set padheight [expr {$rowh + 2}] + } else { + set padheight [expr {$rowh + 1}] + } + set bline [tcl::string::repeat $TSUB [expr {$padwidth +1}]] + set h_lines [lrepeat $padheight $bline] + set hcell_blank [::join $h_lines \n] + set header_frame $hcell_blank + } else { + set bline [tcl::string::repeat $TSUB $padwidth] + set h_lines [lrepeat $rowh $bline] + set hcell_blank [::join $h_lines \n] + # -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 -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ + -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ + ] + } + + append part_header $header_frame\n + + } + incr hrow + } + if {![llength $header_list]} { + #no headers - but we've been asked to show_header + #display a zero content-height header (ie outline if edge is being shown - or bottom bar) + set hlims $header_boxlimits_toprow + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + 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 -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\ + ] + append part_header $header_frame\n + } + set part_header [tcl::string::trimright $part_header \n] + lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight + + set padline [tcl::string::repeat $TSUB $return_headerwidth] + set adjusted_lines [list] + foreach ln [split $part_header \n] { + if {[tcl::string::first $TSUB $ln] >=0} { + lappend adjusted_lines $padline + } else { + lappend adjusted_lines $ln + } + } + set part_header [::join $adjusted_lines \n] + #append output $part_header \n + } + + set r 0 + set rmax [expr {[llength $cells]-1}] + + + set blims_mid $boxlimits + set blims_top $boxlimits + set blims_bot $boxlimits + set blims_top_headerless $boxlimits_headerless + set blims_only $boxlimits + set blims_only_headerless $boxlimits_headerless + if {!$show_seps_h} { + set blims_mid [struct::set difference $blims_mid $midseps_h] + set blims_top [struct::set difference $blims_top $topseps_h] + set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_h] + } + if {!$show_seps_v} { + set blims_mid [struct::set difference $blims_mid $midseps_v] + set blims_top [struct::set difference $blims_top $topseps_v] + set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_v] + set blims_bot [struct::set difference $blims_bot $botseps_v] + set blims_only [struct::set difference $blims_only $onlyseps_v] + set blims_only_headerless [struct::set difference $blims_only_headerless $onlyseps_v] + } + + set colidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range + + set opt_col_ansibase [tcl::dict::get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column + #set colwidth [my column_width $colidx] + + set body_ansibase [tcl::dict::get $o_opts_table -ansibase_body] + #set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body + set body_ansiborder [tcl::dict::get $o_opts_table -ansiborder_body] + if {[tcl::dict::get $o_opts_table -frametype] eq "block"} { + #block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled + #we need to only accept background ansi codes from the columndef ansibase for this + set col_bg [punk::ansi::codetype::sgr_merge_singles [list $opt_col_ansibase] -filter_fg 1] ;#special merge for block borders - don't override fg colours + set border_ansi $body_ansibase$body_ansiborder$col_bg + } else { + set border_ansi $body_ansibase$body_ansiborder + } + + + set r 0 + set ftblock [expr {[tcl::dict::get $o_opts_table -frametype] eq "block"}] + foreach c $cells { + #cells in column - each new c is in a different row + set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] + set row_bg "" + if {$row_ansibase ne ""} { + set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] + } + + set ansibase $body_ansibase$opt_col_ansibase + #todo - joinleft,joinright,joindown based on opts in args + set cell_ansibase "" + + set ansiborder_body_col_row $border_ansi$row_bg + set ansiborder_final $ansiborder_body_col_row + #$c will always have ansi resets due to overtype behaviour ? + #todo - review overtype + if {[punk::ansi::ta::detect $c]} { + #use only the last ansi sequence in the cell value + #Filter out foreground and use background for ansiborder override + set parts [punk::ansi::ta::split_codes_single $c] + #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt + set codes [list] + foreach {pt cd} $parts { + if {$cd ne ""} { + lappend codes $cd + } + } + #set takebg [lindex $parts end-1] + #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] + set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] + #puts --->[ansistring VIEW $codes] + + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { + #special case double reset at end of content + set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters + set ansibase "" + set row_ansibase "" + if {$ftblock} { + set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1] + } + set cell_ansibase $cell_ansi_tail + } else { + #single trailing reset in content + set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase + } + } else { + if {$ftblock} { + #no resets - use cell's bg to extend to the border - only for block frames + set ansiborder_final $ansiborder_body_col_row$cell_bg + } + set cell_ansibase $cell_bg + } + } + + set ansibase_final $ansibase$row_ansibase$cell_ansibase + + if {$r == 0} { + if {$r == $rmax} { + set joins [lremove $joins [lsearch $joins down*]] + set bmap $onlymap + if {$do_show_header} { + set blims $blims_only + } else { + set blims $blims_only_headerless + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] + } + } else { + set bmap $topmap + if {$do_show_header} { + set blims $blims_top + } else { + set blims $blims_top_headerless + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] + } + } + 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 { + if {$r == $rmax} { + set joins [lremove $joins [lsearch $joins down*]] + set bmap $botmap + set blims $blims_bot + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts bottom$opt_posn] ] + } + } else { + set bmap $midmap + set blims $blims_mid ;#will only be reduced from boxlimits if -show_seps was processed above + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] + } + } + 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 + } + #return empty (zero content height) row if no rows + if {![llength $cells]} { + set joins [lremove $joins [lsearch $joins down*]] + #we need to know the width of the column to setup the empty cell properly + #even if no header displayed - we should take account of any defined column widths + set colwidth [my column_width $index_expression] + + if {$do_show_header} { + set blims $blims_only + } else { + append part_body \n + set blims $blims_only_headerless + } + #note that if show_edge is 0 - then for this empty line - we will not expect to see any bars + #This is because the frame with no data had vertical components made entirely of corner elements + #we could just append a newline when -show_edge is zero, but we want the correct width even when empty - for proper column joins when there are colspanned headers. + # + if {![tcl::dict::get $o_opts_table -show_edge]} { + #set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] + #append output [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n + append part_body [tcl::string::repeat " " $colwidth] \n + set return_bodywidth $colwidth + } else { + 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] + } + } + #assert bodywidth is integer >=0 whether there are rows or not + + #trim only 1 newline + if {[tcl::string::index $part_body end] eq "\n"} { + set part_body [tcl::string::range $part_body 0 end-1] + } + set return_bodyheight [textblock::height $part_body] + #append output $part_body + + if {$opt_return eq "string"} { + if {$part_header ne ""} { + set output $part_header + if {$part_body ne ""} { + append output \n $part_body + } + } else { + set output $part_body + } + return $output + } else { + return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] + } + } + + 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 "" + if {[tcl::dict::size $o_columndefs] > 0} { + set range "0..[expr {[tcl::dict::size $o_columndefs] -1}]" + } else { + set range empty + } + error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" + } + #assert cidx is integer >=0 + set num_header_rows [my header_count] + set cdef [tcl::dict::get $o_columndefs $cidx] + set headerlist [tcl::dict::get $cdef -headers] + set ansibase_col [tcl::dict::get $cdef -ansibase] + set textalign [tcl::dict::get $cdef -textalign] + switch -- $textalign { + left {set pad right} + right {set pad left} + default { + set pad "centre" ;#todo? + } + } + + #set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] + #set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] + + #set header_underlay $ansibase_header$cell_line_blank + + #set hdrwidth [my column_width_configured $cidx] + #set all_colspans [my header_colspans] + #we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric + set all_colspans [my header_colspans_numeric] + #JMN + #store configured widths so we don't look up for each header line + #set configured_widths [list] + #foreach c [tcl::dict::keys $o_columndefs] { + # #lappend configured_widths [my column_width $c] + # #we don't just want the width of the column in the body - or the headers will get truncated + # lappend configured_widths [my column_width_configured $c] + #} + + set output [tcl::dict::create] + tcl::dict::set output headers [list] + + set showing_vseps [my Showing_vseps] + for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} { + set hdr [lindex $headerlist $hrow] + #jjj + set header_maxdataheight [tcl::dict::get $o_headerstates $hrow maxheightseen] + #set header_maxdataheight [my header_height $hrow] ;#from cached headerstates + set headerdefminh [tcl::dict::get $o_headerdefs $hrow -minheight] + set headerdefmaxh [tcl::dict::get $o_headerdefs $hrow -maxheight] + if {"$headerdefminh$headerdefmaxh" ne "" && $headerdefminh eq $headerdefmaxh} { + set headerh $headerdefminh ;#exact height defined for the row + } else { + if {$headerdefminh eq ""} { + if {$headerdefmaxh eq ""} { + #both defs empty + set headerh $header_maxdataheight + } else { + set headerh [expr {min(1,$headerdefmaxh,$header_maxdataheight)}] + } + } else { + if {$headerdefmaxh eq ""} { + set headerh [expr {max($headerdefminh,$header_maxdataheight)}] + } else { + if {$header_maxdataheight < $headerdefminh} { + set headerh $headerdefminh + } else { + set headerh [expr {max($headerdefminh,$header_maxdataheight)}] + } + } + } + } + + + set headerrow_colspans [tcl::dict::get $all_colspans $hrow] + set this_span [lindex $headerrow_colspans $cidx] + + #set this_hdrwidth [lindex $configured_widths $cidx] + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign + + set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] + set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] + set hval_lines [split $hdr \n] + #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] + tcl::dict::lappend output headers $hcell + } + + + #set colwidth [my column_width $cidx] + #set cell_line_blank [tcl::string::repeat " " $colwidth] + set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1] + set cell_line_blank [tcl::string::repeat " " $datawidth] + + + + set items [tcl::dict::get $o_columndata $cidx] + #puts "---> columndata $o_columndata" + + #set opt_row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] + #set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase + + tcl::dict::set output cells [list];#ensure we return something for cells key if no items in list + set r 0 + foreach cval $items { + #todo move to row_height method ? + set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] + set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] + set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] + if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { + set rowh $rowdefminh ;#an exact height is defined for the row + } else { + if {$rowdefminh eq ""} { + if {$rowdefmaxh eq ""} { + #both defs empty + set rowh $maxdataheight + } else { + set rowh [expr {min(1,$rowdefmaxh,$maxdataheight)}] + } + } else { + if {$rowdefmaxh eq ""} { + set rowh [expr {max($rowdefminh,$maxdataheight)}] + } else { + if {$maxdataheight < $rowdefminh} { + set rowh $rowdefminh + } else { + set rowh [expr {max($rowdefminh,$maxdataheight)}] + } + } + } + } + + set cell_lines [lrepeat $rowh $cell_line_blank] + #set cell_blank [join $cell_lines \n] + + + set cval_lines [split $cval \n] + #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] + + #//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 + + incr r + } + 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 + } + 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\ + ] + foreach {k v} $args { + switch -- $k { + -usetables {} + default { + error "table debug unrecognised option '$k'. Known options: [tcl::dict::keys $defaults]" + } + } + } + set opts [tcl::dict::merge $defaults $args] + set opt_usetables [tcl::dict::get $opts -usetables] + + puts stdout "rowdefs: $o_rowdefs" + puts stdout "rowstates: $o_rowstates" + #puts stdout "columndefs: $o_columndefs" + puts stdout "columndefs:" + if {!$opt_usetables} { + tcl::dict::for {k v} $o_columndefs { + puts " $k $v" + } + } else { + set t [textblock::class::table new] + $t add_column -headers "Col" + tcl::dict::for {col coldef} $o_columndefs { + foreach property [tcl::dict::keys $coldef] { + if {$property eq "-ansireset"} { + continue + } + $t add_column -headers $property + } + break + } + + #build our inner tables first so we can sync widths + set col_header_tables [tcl::dict::create] + set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths + tcl::dict::for {col coldef} $o_columndefs { + set row [list $col] + set colheaders [tcl::dict::get $coldef -headers] + #inner table probably overkill here ..but just as easy + set htable [textblock::class::table new] + $htable configure -show_header 1 -show_edge 0 -show_hseps 0 + $htable add_column -headers row + $htable add_column -headers text + $htable add_column -headers WxH + $htable add_column -headers span + set hnum 0 + set spans [tcl::dict::get $o_columndefs $col -header_colspans] + foreach h $colheaders s $spans { + lassign [textblock::size $h] _w width _h height + $htable add_row [list "$hnum " $h "${width}x${height}" $s] + incr hnum + } + $htable configure_column 0 -ansibase [a+ web-dimgray] + tcl::dict::set col_header_tables $col $htable + set colwidths [$htable column_widths] + set icol 0 + foreach w $colwidths { + if {$w > [tcl::dict::get $max_widths $icol]} { + tcl::dict::set max_widths $icol $w + } + incr icol + } + } + + #safe jumptable test + #dict for {col coldef} $o_columndefs {} + tcl::dict::for {col coldef} $o_columndefs { + set row [list $col] + #safe jumptable test + #dict for {property val} $coldef {} + tcl::dict::for {property val} $coldef { + switch -- $property { + -ansireset {continue} + -headers { + set htable [tcl::dict::get $col_header_tables $col] + tcl::dict::for {innercol maxw} $max_widths { + $htable configure_column $innercol -minwidth $maxw -blockalign left + } + lappend row [$htable print] + $htable destroy + } + default { + lappend row $val + } + } + } + $t add_row $row + } + + + + + $t configure -show_header 1 + puts stdout [$t print] + $t destroy + } + puts stdout "columnstates: $o_columnstates" + puts stdout "headerdefs: $o_headerdefs" + puts stdout "headerstates: $o_headerstates" + tcl::dict::for {k coldef} $o_columndefs { + if {[tcl::dict::exists $o_columndata $k]} { + set headerlist [tcl::dict::get $coldef -headers] + set coldata [tcl::dict::get $o_columndata $k] + set colinfo "rowcount: [llength $coldata]" + set allfields [concat $headerlist $coldata] + if {[llength $allfields]} { + set widest [tcl::mathfunc::max {*}[lmap v $allfields {textblock::width $v}]] + } else { + set widest 0 + } + append colinfo " widest of headers and data: $widest" + } else { + set colinfo "WARNING - no columndata record for column key '$k'" + } + puts stdout "column $k columndata info: $colinfo" + } + set result "" + set cols [list] + set max [expr {[tcl::dict::size $o_columndefs]-1}] + foreach c [tcl::dict::keys $o_columndefs] { + if {$c == 0} { + lappend cols [my get_column_by_index $c -position left] " " + } elseif {$c == $max} { + lappend cols [my get_column_by_index $c -position right] + } else { + lappend cols [my get_column_by_index $c -position inner] " " + } + } + append result [textblock::join -- {*}$cols] + return $result + } + #column width including headers - but without colspan consideration + method column_width_configured {index_expression} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + #assert cidx is now >=0 integer within the range of defined columns + set cdef [tcl::dict::get $o_columndefs $cidx] + set defminw [tcl::dict::get $cdef -minwidth] + set defmaxw [tcl::dict::get $cdef -maxwidth] + if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { + #an exact width is defined for the column - no need to look at data width + set colwidth $defminw + } else { + #set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1] + set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + #set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1] + #set hwidest_singlespan ?? + set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + set widest [expr {max($hwidest,$bwidest)}] + #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. + #if so - a truncated line shouldn't be included in our width calculation + if {$defminw eq ""} { + if {$defmaxw eq ""} { + set colwidth $widest + } else { + set colwidth [expr {min($defmaxw,$widest)}] + } + } else { + if {$defmaxw eq ""} { + set colwidth [expr {max($defminw,$widest)}] + } else { + if {$widest < $defminw} { + set colwidth $defminw + } else { + if {$widest > $defmaxw} { + set colwidth $defmaxw + } else { + set colwidth [expr {max($defminw,$widest)}] + } + } + } + } + } + return $colwidth + } + + 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 + } + return $o_calculated_column_widths + } + + #width of a table includes borders and seps + #whereas width of a column refers to the borderless width (inner width) + method width {} { + #*** !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 + if {[my Showing_vseps]} { + incr twidth [llength $colwidths] + incr twidth -1 + } + if {[tcl::dict::get $o_opts_table -show_edge]} { + incr twidth 2 + } + return $twidth + } + + #column *body* content width + method basic_column_width {index_expression} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + #puts "===column_width $index_expression" + #assert cidx is now >=0 integer within the range of defined columns + set cdef [tcl::dict::get $o_columndefs $cidx] + set defminw [tcl::dict::get $cdef -minwidth] + set defmaxw [tcl::dict::get $cdef -maxwidth] + if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { + #an exact width is defined for the column - no need to look at data width + #review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header + set colwidth $defminw + } else { + #set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0] + set widest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. + #if so - a truncated line shouldn't be included in our width calculation + if {$defminw eq ""} { + if {$defmaxw eq ""} { + set colwidth $widest + } else { + set colwidth [expr {min($defmaxw,$widest)}] + } + } else { + if {$defmaxw eq ""} { + set colwidth [expr {max($defminw,$widest)}] + } else { + if {$widest < $defminw} { + set colwidth $defminw + } else { + if {$widest > $defmaxw} { + set colwidth $defmaxw + } else { + set colwidth [expr {max($defminw,$widest)}] + } + } + } + } + } + set configured_widths [list] + foreach c [tcl::dict::keys $o_columndefs] { + lappend configured_widths [my column_width_configured $c] + } + set header_colspans [my header_colspans] + set width_max $colwidth + set test_width $colwidth + set showing_vseps [my Showing_vseps] + set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + tcl::dict::for {h colspans} $header_colspans { + set spanc [lindex $colspans $cidx] + #set headers [tcl::dict::get $cdef -headers] + #set thiscol_widest_header 0 + #if {[llength $headers] > 0} { + # set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]] + #} + if {$spanc eq "1"} { + if {$thiscol_widest_header > $colwidth} { + set test_width [expr {max($thiscol_widest_header,$colwidth)}] + if {$defmaxw ne ""} { + set test_width [expr {min($colwidth,$defmaxw)}] + } + } + set width_max [expr {max($test_width,$width_max)}] + continue + } + if {$spanc eq "any" || $spanc > 1} { + set spanned [list] ;#spanned is other columns spanned - not including this one + set cnext [expr {$cidx +1}] + set spanlength [lindex $colspans $cnext] + while {$spanlength eq "0" && $cnext < [llength $colspans]} { + lappend spanned $cnext + incr cnext + set spanlength [lindex $colspans $cnext] + } + set others_width 0 + foreach col $spanned { + incr others_width [lindex $configured_widths $col] + if {$showing_vseps} { + incr others_width 1 + } + } + set total_spanned_width [expr {$width_max + $others_width}] + if {$thiscol_widest_header > $total_spanned_width} { + #this just allocates the extra space in the current column - which is not great. + #A proper algorithm for distributing width created by headers to all the spanned columns is needed. + #This is a tricky problem with multiple header lines and arbitrary spans. + #The calculation should probably be done on the table as a whole first and this function should just look up that result. + #Trying to calculate on a specific column only is unlikely to be easy or efficient. + set needed [expr {$thiscol_widest_header - $total_spanned_width}] + #puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)" + if {$defmaxw ne ""} { + set test_width [expr {min($colwidth+$needed,$defmaxw)}] + } else { + set test_width [expr {$colwidth + $needed}] + } + } + } + set width_max [expr {max($test_width,$width_max)}] + } + + #alternative to all the above shennanigans.. let the body cell data determine the size and just wrap the headers + #could also split the needed width amongst the spanned columns? configurable for whether cells expand? + set expand_first_column 1 + if {$expand_first_column} { + set colwidth $width_max + } + + #puts "---column_width $cidx = $colwidth" + return $colwidth + } + method Showing_vseps {} { + #review - show_seps and override mechanism for show_vseps show_hseps - document. + set seps [tcl::dict::get $o_opts_table -show_seps] + set vseps [tcl::dict::get $o_opts_table -show_vseps] + if {$seps eq ""} { + if {$vseps eq "" || $vseps} { + return true + } + } elseif {$seps} { + if {$vseps eq "" || $vseps} { + return true + } + } else { + if {$vseps ne "" && $vseps} { + return true + } + } + return false + } + + method column_datawidth {index_expression args} { + set opts [tcl::dict::create\ + -headers 0\ + -footers 0\ + -colspan unspecified\ + -data 1\ + -cached 1\ + ] + #NOTE: -colspan any is not the same as * + # + #-colspan is relevant to header/footer data only + foreach {k v} $args { + switch -- $k { + -headers - -footers - -colspan - -data - -cached { + tcl::dict::set opts $k $v + } + default { + error "column_datawidth unrecognised flag '$k'. Known flags: [tcl::dict::keys $opts]" + } + } + } + set opt_colspan [tcl::dict::get $opts -colspan] + switch -- $opt_colspan { + * - unspecified {} + any { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0 (use header_colspans_numeric to get actual spans)" + } + default { + if {![string is integer -strict $opt_colspan]} { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0" + } + } + } + + + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + + if {[tcl::dict::get $opts -cached]} { + set hwidest 0 + set bwidest 0 + set fwidest 0 + if {[tcl::dict::get $opts -headers]} { + if {$opt_colspan in {* unspecified}} { + set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + } else { + #this is not cached + # -- --- --- --- + set colheaders [tcl::dict::get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans_numeric] + set hlist [list] + tcl::dict::for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + # -- --- --- --- + } + } + if {[tcl::dict::get $opts -data]} { + set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + } + if {[tcl::dict::get $opts -footers]} { + #TODO! + #set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthfooterseen] + } + return [expr {max($hwidest,$bwidest,$fwidest)}] + } + + #assert cidx is >=0 integer in valid range of keys for o_columndefs + set values [list] + set hwidest 0 + if {[tcl::dict::get $opts -headers]} { + if {$opt_colspan in {* unspecified}} { + lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] + } else { + # -- --- --- --- + set colheaders [tcl::dict::get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans_numeric] + set hlist [list] + tcl::dict::for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + # -- --- --- --- + } + } + if {[tcl::dict::get $opts -data]} { + if {[tcl::dict::exists $o_columndata $cidx]} { + lappend values {*}[tcl::dict::get $o_columndata $cidx] + } + } + if {[tcl::dict::get $opts -footers]} { + lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] + } + if {[llength $values]} { + set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] + set widest [expr {max($valwidest,$hwidest)}] + } else { + set widest $hwidest + } + return $widest + } + #print1 uses basic column joining - useful for testing/debug especially with colspans + method print1 {args} { + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0 } + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set colposn 0 + set numposns [llength $cols] + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + lappend blocks [my get_column_by_index $c {*}$flags] + incr colposn + } + if {[llength $blocks]} { + return [textblock::join -- {*}$blocks] + } else { + return "No columns matched" + } + } + method columncalc_spans {allocmethod} { + set colwidths [tcl::dict::create] ;# to use tcl::dict::incr + set colspace_added [tcl::dict::create] + + set ordered_spans [tcl::dict::create] + tcl::dict::for {col spandata} [my spangroups] { + set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] + set minwidth [tcl::dict::get $o_columndefs $col -minwidth] + set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] + if {$minwidth ne ""} { + if {$dwidth < $minwidth} { + set dwidth $minwidth + } + } + if {$maxwidth ne ""} { + if {$dwidth > $maxwidth} { + set dwidth $maxwidth + } + } + tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered + tcl::dict::set colspace_added $col 0 + + set spanlengths [tcl::dict::get $spandata spanlengths] + foreach slen $spanlengths { + set spans [tcl::dict::get $spandata spangroups $slen] + set spans [lsort -index 7 -integer $spans] + foreach s $spans { + set hwidth [tcl::dict::get $s headerwidth] + set hrow [tcl::dict::get $s hrow] + set scol [tcl::dict::get $s startcol] + tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth + tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth + } + } + } + + #safe jumptable test + #dict for {spanid spandata} $ordered_spans {} + tcl::dict::for {spanid spandata} $ordered_spans { + lassign [split $spanid ,] startcol hrow + set memcols [tcl::dict::get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios + set colids [tcl::dict::keys $memcols] + set hwidth [tcl::dict::get $spandata headerwidth] + set num_cols_spanned [tcl::dict::size $memcols] + if {$num_cols_spanned == 1} { + set col [lindex $memcols 0] + set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] + if {$space_to_alloc > 0} { + set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] + if {$maxwidth ne ""} { + if {$maxwidth > [tcl::dict::get $colwidths $col]} { + set can_alloc [expr {$maxwidth - [tcl::dict::get $colwidths $col]}] + } else { + set can_alloc 0 + } + set will_alloc [expr {min($space_to_alloc,$can_alloc)}] + } else { + set will_alloc $space_to_alloc + } + if {$will_alloc} { + #tcl::dict::set colwidths $col $hwidth + tcl::dict::incr colwidths $col $will_alloc + tcl::dict::set colspace_added $col $will_alloc + } + #log! + #if {$will_alloc < $space_to_alloc} { + # #todo - debug only + # puts stderr "max width $maxwidth hit for col $col - cannot allocate extra [expr {$space_to_alloc - $will_alloc}]" + #} + } + } elseif {$num_cols_spanned > 1} { + set spannedwidth 0 + foreach col $colids { + incr spannedwidth [tcl::dict::get $colwidths $col] + } + set space_to_alloc [expr {$hwidth - $spannedwidth}] + if {[my Showing_vseps]} { + set sepcount [expr {$num_cols_spanned -1}] + incr space_to_alloc -$sepcount + } + #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added + switch -- $allocmethod { + least { + #add to least-expanded each time + #safer than method 1 - pretty balanced + if {$space_to_alloc > 0} { + for {set i 0} {$i < $space_to_alloc} {incr i} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] + foreach testcolid $ordered_all_colids { + if {$testcolid in $colids} { + #assert - we will always find a match + set colid $testcolid + break + } + } + tcl::dict::incr colwidths $colid + tcl::dict::incr colspace_added $colid + } + } + } + least_unmaxed { + #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth + #(we should be able to collapse column width to zero and have header colspans gracefully respond) + #add to least-expanded each time + #safer than method 1 - pretty balanced + if {$space_to_alloc > 0} { + for {set i 0} {$i < $space_to_alloc} {incr i} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] + set colid "" + foreach testcolid $ordered_all_colids { + set maxwidth [tcl::dict::get $o_columndefs $testcolid -maxwidth] + set can_alloc [expr {$maxwidth eq "" || $maxwidth > [tcl::dict::get $colwidths $testcolid]}] + if {$testcolid in $colids} { + if {$can_alloc} { + set colid $testcolid + break + } else { + #remove from future consideration in for loop + #log! + #puts stderr "max width $maxwidth hit for col $testcolid" + tcl::dict::unset colspace_added $testcolid + } + } + } + if {$colid ne ""} { + tcl::dict::incr colwidths $colid + tcl::dict::incr colspace_added $colid + } + } + } + } + all { + #adds space to all columns - not just those spanned - risk of underallocating and truncating some headers! + #probably not a good idea for tables with complex headers and spans + while {$space_to_alloc > 0} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_colids [tcl::dict::keys $ordered_colspace_added] + + foreach col $ordered_colids { + tcl::dict::incr colwidths $col + tcl::dict::incr colspace_added $col + incr space_to_alloc -1 + if {$space_to_alloc == 0} { + break + } + } + } + + } + } + } + } + + set column_widths [tcl::dict::values $colwidths] + #todo - -maxwidth etc + set table_minwidth [tcl::dict::get $o_opts_table -minwidth] ;#min width including frame elements + if {[tcl::string::is integer -strict $table_minwidth]} { + set contentwidth [tcl::mathop::+ {*}$column_widths] + set twidth $contentwidth + if {[my Showing_vseps]} { + incr twidth [llength $column_widths] + incr twidth -1 + } + if {[tcl::dict::get $o_opts_table -show_edge]} { + incr twidth 2 + } + # + set shortfall [expr {$table_minwidth - $twidth}] + if {$shortfall > 0} { + set space_to_alloc $shortfall + while {$space_to_alloc > 0} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_colids [tcl::dict::keys $ordered_colspace_added] + + foreach col $ordered_colids { + tcl::dict::incr colwidths $col + tcl::dict::incr colspace_added $col + incr space_to_alloc -1 + if {$space_to_alloc == 0} { + break + } + } + } + set column_widths [tcl::dict::values $colwidths] + } + + } + + return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] + } + + #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 + foreach c [tcl::dict::keys $o_columndefs] { + tcl::dict::set spangroups $c [list spanlengths {}] + set spanlist [my column_get_spaninfo $c] + set index_spanlen_val 5 + set spanlist [lsort -index $index_spanlen_val -integer $spanlist] + set ungrouped $spanlist + + while {[llength $ungrouped]} { + set spanlen [lindex $ungrouped 0 $index_spanlen_val] + set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen] + set sgroup [list] + foreach p $spangroup_posns { + set spaninfo [lindex $ungrouped $p] + set hcol [tcl::dict::get $spaninfo startcol] + set hrow [tcl::dict::get $spaninfo hrow] + set header [lindex [tcl::dict::get $o_columndefs $hcol -headers] $hrow] + if {[tcl::dict::exists $headerwidths $hcol,$hrow]} { + set hwidth [tcl::dict::get $headerwidths $hcol,$hrow] + } else { + set hwidth [textblock::width $header] + tcl::dict::set headerwidths $hcol,$hrow $hwidth + } + lappend spaninfo headerwidth $hwidth + lappend sgroup $spaninfo + } + set spanlengths [tcl::dict::get $spangroups $c spanlengths] + lappend spanlengths $spanlen + tcl::dict::set spangroups $c spanlengths $spanlengths + tcl::dict::set spangroups $c spangroups $spanlen $sgroup + set ungrouped [lremove $ungrouped {*}$spangroup_posns] + } + } + return $spangroups + } + method column_get_own_spans {cidx} { + set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] + } + method column_get_spaninfo {cidx} { + set spans_by_header [my header_colspans] + set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] + set spaninfo [list] + set numcols [tcl::dict::size $o_columndefs] + #note that 'any' can occur in positions other than column 0 - meaning any remaining until next non-zero span + tcl::dict::for {hrow rawspans} $spans_by_header { + set thiscol_spanval [lindex $rawspans $cidx] + if {$thiscol_spanval eq "any" || $thiscol_spanval > 0} { + set spanstartcol $cidx ;#own column + if {$thiscol_spanval eq "any"} { + #scan right to first non-zero to get actual length of 'any' span + #REVIEW! + set spanlen 1 + for {set i [expr {$cidx+1}]} {$i < $numcols} {incr i} { + #abort at next any or number or empty string + if {[lindex $rawspans $i] ne "0"} { + break + } + incr spanlen + } + #set spanlen [expr {$numcols - $cidx}] + } else { + set spanlen $thiscol_spanval + } + } else { + #look left til we see an any or a non-zero value + for {set i $cidx} {$i > -1} {incr i -1} { + set s [lindex $rawspans $i] + if {$s eq "any" || $s > 0} { + set spanstartcol $i + if {$s eq "any"} { + #REVIEW! + #set spanlen [expr {$numcols - $i}] + set spanlen 1 + #now scan right to see how long the 'any' actually is + for {set j [expr {$i+1}]} {$j < $numcols} {incr j} { + if {[lindex $rawspans $j] ne "0"} { + break + } + incr spanlen + } + } else { + set spanlen $s + } + break + } + } + } + #assert - we should always find 1 answer for each header row + lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen] + } + return $spaninfo + } + method calculate_column_widths {args} { + set column_count [tcl::dict::size $o_columndefs] + + set opts [tcl::dict::create\ + -algorithm $o_column_width_algorithm\ + ] + foreach {k v} $args { + switch -- $k { + -algorithm { + tcl::dict::set opts $k $v + } + default { + error "Unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + set opt_algorithm [tcl::dict::get $opts -algorithm] + #puts stderr "--- recalculating column widths -algorithm $opt_algorithm" + set known_algorithms [list basic simplistic span span2] + switch -- $opt_algorithm { + basic { + #basic column by column - This allocates extra space to first span/column as they're encountered. + #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans + #The header values can extend over some of the spanned columns - but not optimally so. + set o_calculated_column_widths [list] + for {set c 0} {$c < $column_count} {incr c} { + lappend o_calculated_column_widths [my basic_column_width $c] + } + } + simplistic { + #just uses the widest column data or header element. + #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column + #This is a conservative option potentially useful in testing/debugging. + set o_calculated_column_widths [list] + for {set c 0} {$c < $column_count} {incr c} { + lappend o_calculated_column_widths [my column_width_configured $c] + } + } + span { + #widest of smallest spans first method + #set calcresult [my columncalc_spans least] + set calcresult [my columncalc_spans least_unmaxed] + set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] + } + span2 { + #allocates more evenly - but truncates headers sometimes + set calcresult [my columncalc_spans all] + set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] + } + default { + error "calculate_column_widths unknown algorithm $opt_algorithm. Known algorithms: $known_algorithms" + } + } + #remember the last algorithm used + set o_column_width_algorithm $opt_algorithm + return $o_calculated_column_widths + } + method print2 {args} { + variable full_column_cache + set full_column_cache [tcl::dict::create] + + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set colposn 0 + set numposns [llength $cols] + set padwidth 0 + set table "" + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + #lappend blocks [my get_column_by_index $c {*}$flags] + #todo - only check and store in cache if table has header or footer colspans > 1 + if {[tcl::dict::exists $full_column_cache $c]} { + #puts "!!print used full_column_cache for $c" + set columninfo [tcl::dict::get $full_column_cache $c] + } else { + set columninfo [my get_column_by_index $c -return dict {*}$flags] + tcl::dict::set full_column_cache $c $columninfo + } + set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] + set bodywidth [tcl::dict::get $columninfo bodywidth] + + if {$table eq ""} { + set table $nextcol + set height [textblock::height $table] ;#only need to get height once at start + } else { + set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] + set table [overtype::renderspace -expand_right 1 -transparent $TSUB $table[unset table] $nextcol] + #JMN + + #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] + #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] + } + incr padwidth $bodywidth + incr colposn + } + + if {[llength $cols]} { + #return [textblock::join -- {*}$blocks] + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + + # using -startcolumn to do slightly less work + method print3 {args} { + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set numposns [llength $cols] + set colposn 0 + set padwidth 0 + set table "" + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + set columninfo [my get_column_by_index $c -return dict {*}$flags] + set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] + set bodywidth [tcl::dict::get $columninfo bodywidth] + + if {$table eq ""} { + set table $nextcol + set height [textblock::height $table] ;#only need to get height once at start + } else { + set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] + } + incr padwidth $bodywidth + incr colposn + } + + if {[llength $cols]} { + #return [textblock::join -- {*}$blocks] + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + + #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 { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set numposns [llength $cols] + set colposn 0 + set padwidth 0 + set header_build "" + set body_blocks [list] + set headerheight 0 + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + set columninfo [my get_column_by_index $c -return dict {*}$flags] + #set nextcol [tcl::dict::get $columninfo column] + set bodywidth [tcl::dict::get $columninfo bodywidth] + set headerheight [tcl::dict::get $columninfo headerheight] + #set nextcol_lines [split $nextcol \n] + #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] + #set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n] + set nextcol_header [tcl::dict::get $columninfo header] + set nextcol_body [tcl::dict::get $columninfo body] + + if {$header_build eq "" && ![llength $body_blocks]} { + set header_build $nextcol_header + } else { + if {$headerheight > 0} { + set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] + } + #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] + } + lappend body_blocks $nextcol_body + incr padwidth $bodywidth + incr colposn + } + if {![llength $body_blocks]} { + set body_build "" + } else { + #body blocks should not be ragged - so can use join_basic + set body_build [textblock::join_basic -- {*}$body_blocks] + } + if {$headerheight > 0} { + set table [tcl::string::cat $header_build \n $body_build] + } else { + set table $body_build + } + + if {[llength $cols]} { + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + 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 + } + + #*** !doctools + #[list_end] + }] + #*** !doctools + # [list_end] [comment {- end enumeration provider_classes }] + #[list_end] [comment {- end itemized list textblock::class groupings -}] + } + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# +#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 *} + tcl::namespace::import ::term::ansi::code::macros::cd::* + tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} + } + proc spantest {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2] + $t configure_column 0 -header_colspans {3 4 5 any 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + proc spantest1 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers [list "span3-any longer than other span any" "1-span4\n2-span4 second line" "span-any short aligned?" "span5/5 longest etc blah 123" span2] + $t configure_column 0 -header_colspans {any 4 any 5 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 0 0 0} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + $t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs) + return $t + } + + #more complex colspans + proc spantest2 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} + $t configure_column 0 -header_colspans {3 4 1 any 2} + $t configure_column 1 -header_colspans {0 0 2 0 0} + $t configure_column 2 -headers {"" "" "" "" c2span2} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 2 0 0} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + proc spantest3 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1} + $t configure_column 0 -header_colspans {3 4 1 any 2 1} + $t configure_column 1 -header_colspans {0 0 4 0 0 1} + $t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"} + $t configure_column 2 -headers {"" "" "" "" "" c2span2} + $t configure_column 2 -header_colspans {0 0 0 0 1 2} + $t configure_column 4 -headers {"4" "444" "" "" "" "44"} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + + punk::args::define { + @id -id ::textblock::periodic + @cmd -name textblock::periodic -help "A rudimentary periodic table + This is primarily a test of textblock::class::table" + + -return -default table\ + -choices {table tableobject}\ + -help "default choice 'table' returns the displayable table output" + -compact -default 1 -type boolean -help "compact true defaults: -show_vseps 0 -show_header 0 -show_edge 0" + -frame -default 1 -type boolean + -show_vseps -default "" -type boolean + -show_header -default "" -type boolean + -show_edge -default "" -type boolean + -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" + @values -min 0 -max 0 + } + + proc periodic {args} { + #For an impressive interactive terminal app (javascript) + # see: https://github.com/spirometaxas/periodic-table-cli + set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + set opt_return [tcl::dict::get $opts -return] + if {[tcl::dict::get $opts -forcecolour]} { + set fc forcecolour + } else { + set fc "" + } + + #examples ptable.com + set elements [list\ + 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ + 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ + 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ + 4 K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr\ + 5 Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe\ + 6 Cs Ba "" Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn\ + 7 Fr Ra "" Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og\ + " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ + "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ + "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ + ] + + set type_colours [list] + + set ecat [tcl::dict::create] + + set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] + set ansi [a+ {*}$fc web-black Web-gold] + set val [list ansi $ansi cat alkaline_earth] + foreach e $cat_alkaline_earth { + tcl::dict::set ecat $e $val + } + + set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] + #set ansi [a+ {*}$fc web-black Web-lightgreen] + set ansi [a+ {*}$fc black Term-113] + set val [list ansi $ansi cat reactive_nonmetal] + foreach e $cat_reactive_nonmetal { + tcl::dict::set ecat $e $val + } + + set cat [list Li Na K Rb Cs Fr] + #set ansi [a+ {*}$fc web-black Web-Khaki] + set ansi [a+ {*}$fc black Term-lightgoldenrod2] + set val [list ansi $ansi cat alkali_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] + #set ansi [a+ {*}$fc web-black Web-lightsalmon] + set ansi [a+ {*}$fc black Term-orange1] + set val [list ansi $ansi cat transition_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Al Ga In Sn Tl Pb Bi Po] + set ansi [a+ {*}$fc web-black Web-lightskyblue] + set val [list ansi $ansi cat post_transition_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list B Si Ge As Sb Te At] + #set ansi [a+ {*}$fc web-black Web-turquoise] + set ansi [a+ {*}$fc black Brightcyan] + set val [list ansi $ansi cat metalloids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list He Ne Ar Kr Xe Rn] + set ansi [a+ {*}$fc web-black Web-orchid] + set val [list ansi $ansi cat noble_gases] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] + set ansi [a+ {*}$fc web-black Web-plum] + set val [list ansi $ansi cat actinoids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] + #set ansi [a+ {*}$fc web-black Web-tan] + set ansi [a+ {*}$fc black Term-tan] + set val [list ansi $ansi cat lanthanoids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set ansi [a+ {*}$fc web-black Web-whitesmoke] + set val [list ansi $ansi cat other] + foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { + tcl::dict::set ecat $e $val + } + + set elements1 [list] + set RST [a+] + foreach e $elements { + if {[tcl::dict::exists $ecat $e]} { + set ansi [tcl::dict::get $ecat $e ansi] + #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] + #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway + lappend elements1 $ansi$e + } else { + lappend elements1 $e + } + } + + set t [list_as_table -columns 19 -return tableobject $elements1] + #(defaults to show_hseps 0) + + #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options + + set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] + set c 0 + foreach h $header_0 { + $t configure_column $c -headers [list $h] -minwidth 2 + incr c + } + set ccount [$t column_count] + for {set c 0} {$c < $ccount} {incr c} { + $t configure_column $c -minwidth 3 + } + if {[tcl::dict::get $opts -compact]} { + #compact defaults - but let explicit arguments override + set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0] + } else { + set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1] + } + dict for {k v} $conf { + if {[dict get $opts $k] ne ""} { + dict set conf $k [dict get $opts $k] + } + } + + set moreopts [dict create\ + -frametype_header light\ + -ansiborder_header [a+ {*}$fc brightwhite]\ + -ansibase_header [a+ {*}$fc Black]\ + -ansibase_body [a+ {*}$fc Black]\ + -ansiborder_body [a+ {*}$fc black]\ + -frametype block + ] + $t configure {*}[dict merge $conf $moreopts] + + #-ansiborder_header [a+ {*}$fc web-white]\ + + if {$opt_return eq "table"} { + 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 -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + } else { + set output [$t print] + } + $t destroy + return $output + } + return $t + } + + proc bookend_lines {block start {end "\x1b\[m"}} { + set out "" + foreach ln [split $block \n] { + append out $start $ln $end \n + } + return [string range $out 0 end-1] + } + proc ansibase_lines {block {newprefix ""}} { + set base "" + set out "" + if {$newprefix eq ""} { + if {![punk::ansi::ta::detect $block]} { + return $block + } + foreach ln [split $block \n] { + set parts [punk::ansi::ta::split_codes $ln] + if {[lindex $parts 0] eq ""} { + if {[lindex $parts 1] ne "" && ![punk::ansi::codetype::is_sgr_reset [lindex $parts 1]]} { + set base [lindex $parts 1] + append out $base + } else { + append out $base + } + } else { + #leading plaintext - maintain our base + append out $base [lindex $parts 0] [lindex $parts 1] + } + + set code_idx 3 + foreach {pt code} [lrange $parts 2 end] { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set parts [linsert $parts $code_idx+1 $base] + } + incr code_idx 2 + } + append out {*}[lrange $parts 2 end] \n + } + return [string range $out 0 end-1] + } else { + set base $newprefix + if {![punk::ansi::ta::detect $block]} { + foreach ln [split $block \n] { + append out $base $ln \n + } + return $out + } + foreach ln [split $block \n] { + set parts [punk::ansi::ta::split_codes $ln] + set code_idx 1 + set offset 0 + foreach {pt code} $parts { + if {$code_idx == 1} { + #first pt & code + if {$pt ne ""} { + #leading plaintext + set parts [linsert $parts 0 $base] + incr offset + } + } + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set parts [linsert $parts [expr {$code_idx+1+$offset}] $base] + incr offset + } + incr code_idx 2 + } + append out {*}$parts \n + } + return [string range $out 0 end-1] + } + } + + set FRAMETYPES [textblock::frametypes] + punk::args::define [punk::lib::tstr -return string { + @id -id ::textblock::list_as_table + @cmd -name "textblock::list_as_table" -help\ + "Display a list in a bordered 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 "Each supplied -header argument is a header row. + The number of values for each must be <= number of columns" + -show_header -type boolean\ + -help "Whether to show a header row. + Omit 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 + Will default to 2 if not using an existing -table object" + + @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_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 count [llength $datalist] + + set is_new_table 0 + if {$existing_table ne ""} { + if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} { + error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])" + } + set t $existing_table + foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} { + if {[tcl::dict::get $opts $prop] ne ""} { + $t configure $prop [tcl::dict::get $opts $prop] + } + } + if {[dict get $opts -action] eq "replace"} { + $t row_clear + } + set cols [$t column_count] + if {[tcl::string::is integer -strict $opt_columns]} { + if {$opt_columns > $cols} { + set extra [expr {$opt_columns - $cols}] + for {set c 0} {$c < $extra} {incr c} { + $t add_column + } + } elseif {$opt_columns < $cols} { + #todo - auto add blank values in the datalist + error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported" + } + set cols [$t column_count] + } + } else { + set is_new_table 1 + set colheaders {} + if {[tcl::dict::get $opts -colheaders] ne ""} { + set colheaders [dict get $opts -colheaders] + } else { + set colheaders [list] + } + set r 0 + foreach ch $colheaders { + set rows [llength $ch] + if {$r < $rows} { + set r $rows + } + } + if {[llength [tcl::dict::get $opts -header]]} { + foreach hrow [tcl::dict::get $opts -header] { + set c 0 + foreach cell $hrow { + if {[llength $colheaders] < $c+1} { + lappend colheaders [lrepeat $r {}] + } + set colinfo [lindex $colheaders $c] + if {$r > [llength $colinfo]} { + set diff [expr {$r - [llength $colinfo]}] + lappend colinfo {*}[lrepeat $diff {}] + } + lappend colinfo $cell + lset colheaders $c $colinfo + incr c + } + incr r + } + } + + + if {[llength $colheaders] > 0} { + if {![tcl::dict::exists $opts received -show_header]} { + set show_header 1 + } else { + set show_header [tcl::dict::get $opts -show_header] + } + } else { + if {![tcl::dict::exists $opts received -show_header]} { + set show_header 0 + } else { + set show_header [tcl::dict::get $opts -show_header] + } + } + + if {[tcl::string::is integer -strict $opt_columns]} { + set cols $opt_columns + if {[llength $colheaders] && $cols != [llength $colheaders]} { + error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $colheaders])" + } + } else { + #review + if {[llength $colheaders]} { + set cols [llength $colheaders] + } else { + set cols 2 ;#seems a reasonable default + } + } + #defaults for new table only + #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_vseps] eq ""} { + tcl::dict::set opts -show_vseps 1 + } + if {[tcl::dict::get $opts -show_hseps] eq ""} { + tcl::dict::set opts -show_hseps 0 + } + + set t [textblock::class::table new\ + -show_header $show_header\ + -show_edge [tcl::dict::get $opts -show_edge]\ + -frametype [tcl::dict::get $opts -frametype]\ + -show_seps [tcl::dict::get $opts -show_seps]\ + -show_vseps [tcl::dict::get $opts -show_vseps]\ + -show_hseps [tcl::dict::get $opts -show_hseps]\ + ] + if {[llength $colheaders]} { + for {set c 0} {$c < $cols} {incr c} { + $t add_column -headers [lindex $colheaders $c] + } + } else { + for {set c 0} {$c < $cols} {incr c} { + $t add_column -headers [list $c] + } + } + } + + set full_rows [expr {$count / $cols}] + set last_items [expr {$count % $cols}] + + + set rowdata [list] + set row [list] + set i 0 + if {$full_rows > 0} { + for {set r 0} {$r < $full_rows} {incr r} { + set j [expr {$i + ($cols -1)}] + set row [lrange $datalist $i $j] + incr i $cols + lappend rowdata $row + } + } + if {$last_items > 0} { + set idx [expr {$last_items -1}] + lappend rowdata [lrange $datalist end-$idx end] + } + foreach row $rowdata { + set shortfall [expr {$cols - [llength $row]}] + if {$shortfall > 0} { + #set row [concat $row [lrepeat $shortfall ""]] + lappend row {*}[lrepeat $shortfall ""] + } + $t add_row $row + } + #puts stdout $rowdata + if {[tcl::dict::get $opts -return] eq "table"} { + set result [$t print] + if {$is_new_table} { + $t destroy + } + return $result + } else { + return $t + } + } + #return a homogenous block of characters - ie lines all same length, all same character + #printing-width in terminal columns is not necessarily same as blockwidth even if a single char is passed (could be full-width unicode character) + #This can have ansi SGR codes - but to repeat blocks containing ansi-movements, the block should first be rendered to a static output with something like overtype::left + proc block {blockwidth blockheight {char " "}} { + if {$blockwidth < 0} { + error "textblock::block blockwidth must be an integer greater than or equal to zero" + } + if {$blockheight <= 0} { + error "textblock::block blockheight must be a positive integer" + } + if {$char eq ""} {return ""} + #using tcl::string::length is ok + if {[tcl::string::length $char] == 1} { + set row [tcl::string::repeat $char $blockwidth] + set mtrx [lrepeat $blockheight $row] + return [::join $mtrx \n] + } else { + set charblock [tcl::string::map [list \r\n \n] $char] + if {[tcl::string::last \n $charblock] >= 0} { + if {$blockwidth > 1} { + #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) + set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] + } else { + set row $charblock + } + } else { + set row [tcl::string::repeat $char $blockwidth] + } + set mtrx [lrepeat $blockheight $row] + return [::join $mtrx \n] + } + } + + + punk::args::define { + @id -id ::textblock::testblock + @cmd -name textblock::testblock -help\ + "Create a block of characters size + columns wide and size rows tall. + (which on a terminal will show as a + vertically oriented rectangle due to + cells being taller than their width) + + The characters used are + 123456789ABCDEF + " + -size -type integer\ + -default 15\ + -optional 1\ + -range {1 15} + -direction -default horizontal\ + -choices {horizontal vertical}\ + -help\ + "When rainbow is in the colour list, + this also affects the direction of + colour changes" + @values -min 0 -max 2 + colour -type list -default {} -optional 1 -help\ + "List of Ansi colour names + e.g. testblock 10 {white Red} + produces a block of character 10x10 + with white text on red bacground + + The additional pseudo-color 'rainbow' + is available. + " + } + + proc testblock {args} { + set argd [punk::args::get_by_id ::textblock::testblock $args] + set colour [dict get $argd values colour] + set size [dict get $argd opts -size] + + set rainbow_list [list] + lappend rainbow_list {30 47} ;#black White + lappend rainbow_list {31 46} ;#red Cyan + lappend rainbow_list {32 45} ;#green Purple + lappend rainbow_list {33 44} ;#yellow Blue + lappend rainbow_list {34 43} ;#blue Yellow + lappend rainbow_list {35 42} ;#purple Green + lappend rainbow_list {36 41} ;#cyan Red + lappend rainbow_list {37 40} ;#white Black + lappend rainbow_list {black Yellow} + lappend rainbow_list red + lappend rainbow_list green + lappend rainbow_list yellow + lappend rainbow_list blue + lappend rainbow_list purple + lappend rainbow_list cyan + lappend rainbow_list {white Red} + + #set rainbow_direction "horizontal" + #set vpos [lsearch $colour vertical] + #if {$vpos >= 0} { + # set rainbow_direction vertical + # set colour [lremove $colour $vpos] + #} + #set hpos [lsearch $colour horizontal] + #if {$hpos >=0} { + # #horizontal is the default and superfluous but allowed for symmetry + # set colour [lremove $colour $hpos] + #} + set direction [dict get $argd opts -direction] + + + + 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 "" + } else { + set RST [a] + } + if {"rainbow" in $colour && $direction eq "vertical"} { + #column first - colour change each column + set c [::join $charsubset \n] + + set clist [list] + for {set i 0} {$i <$size} {incr i} { + set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] + set ansi [a+ {*}$colour2] + + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] + lappend clist ${ansicode}$c$RST + } + if {"noreset" in $colour} { + return [textblock::join_basic -ansiresets 0 -- {*}$clist] + } else { + return [textblock::join_basic -- {*}$clist] + } + } elseif {"rainbow" in $colour} { + #direction must be horizontal + set block "" + for {set r 0} {$r < $size} {incr r} { + set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] + set ansi [a+ {*}$colour2] + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] + set row "$ansicode" + foreach c $charsubset { + append row $c + } + append row $RST + append block $row\n + } + set block [tcl::string::trimright $block \n] + return $block + } else { + #row first - + set rows [list] + foreach ch $charsubset { + lappend rows [tcl::string::repeat $ch $size] + } + set block [::join $rows \n] + if {$colour ne ""} { + set block [a+ {*}$colour]$block$RST + } + return $block + } + } + interp alias {} testblock {} textblock::testblock + + #todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table + proc width {textblock} { + #backspaces, vertical tabs ? + if {$textblock eq ""} { + return 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 {[string length $textblock] > 1 && [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}]] + } + 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 {[string length $textblock] > 1 && [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] + if {$firstnl >= 0} { + set tl [tcl::string::range $textblock 0 $firstnl] + } else { + set tl $textblock + } + if {[punk::ansi::ta::detect $tl]} { + set tl [punk::ansi::ansistripraw $tl] + } + return [punk::char::ansifreestring_width $tl] + } + #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. + proc string_length_line_max {textblock} { + #tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + set max 0 + foreach ln [split $textblock \n] { + if {[tcl::string::length $ln] > $max} {set max [tcl::string::length $ln]} + } + return $max + } + #*slightly* slower + #proc string_length_line_max {textblock} { + # tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + #} + proc string_length_line_min textblock { + tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + } + + proc height {textblock} { + #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le + #empty string still has height 1 (at least for left-right/right-left languages) + + #vertical tab on a proper terminal should move directly down. + #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) + + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + } + #MAINTENANCE - same as overtype::blocksize? + proc size {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack + 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] + } + #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests + if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] + set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + } else { + set width [punk::char::ansifreestring_width $textblock] + } + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height + } + proc size2 {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack + 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] + } + #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests + if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] + set lines [split $textblock \n] + set num_le [expr {[llength $lines]-1}] + #set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]] + set width 0 + foreach ln $lines { + set w [::punk::char::ansifreestring_width $ln] + if {$w > $width} { + set width $w + } + } + } else { + set num_le 0 + set width [punk::char::ansifreestring_width $textblock] + } + #set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height + } + proc size_as_opts {textblock} { + set sz [size $textblock] + return [dict create -width [dict get $sz width] -height [dict get $sz height]] + } + proc size_as_list {textblock} { + set sz [size $textblock] + return [list [dict get $sz width] [dict get $sz height]] + } + #must be able to handle block as string with or without newlines + #if no newlines - attempt to treat as a list + #must handle whitespace-only string,list elements, and/or lines. + #reviewing 2024 - this seems like too much magic! + proc width1 {block} { + if {$block eq ""} { + return 0 + } + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set block [textutil::tabify::untabify2 $block $tw] + if {[tcl::string::last \n $block] >= 0} { + return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]] + } + if {[catch {llength $block}]} { + return [::punk::char::string_width [ansistrip $block]] + } + if {[llength $block] == 0} { + #could be just a whitespace string + return [tcl::string::length $block] + } + return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]] + } + + #we shouldn't make textblock depend on the punk pipeline system + #pipealias ::textblock::padleft .= {list $input [tcl::string::repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" + foreach {k v} $args { + switch -- $k { + -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { + tcl::dict::set opts $k $v + } + default { + error "textblock::pad unrecognised option '$k'. Usage: $usage" + } + } + } + # -- --- --- --- --- --- --- --- --- --- + set padchar [tcl::dict::get $opts -padchar] + #if padchar width (screen width) > 1 - length calculations will not be correct + #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map + #The caller may also use ansi within the padchar - although it's unlikely to be efficient. + # -- --- --- --- --- --- --- --- --- --- + set known_whiches [list l left r right c center centre] + set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] + switch -- $opt_which { + center - centre - c { + set which c + } + left - l { + set which l + } + right - r { + set which r + } + default { + error "textblock::pad unrecognised value for -which option. Known values $known_whiches" + } + } + # -- --- --- --- --- --- --- --- --- --- + set opt_width [tcl::dict::get $opts -width] + switch -- $opt_width { + "" - auto { + set width auto + } + default { + if {![tcl::string::is integer -strict $opt_width] || $opt_width < 0} { + error "textblock::pad -width must be an integer >=0" + } + set width $opt_width + } + } + # -- --- --- --- --- --- --- --- --- --- + set opt_withinansi [tcl::dict::get $opts -within_ansi] + switch -- $opt_withinansi { + 0 - 1 {} + default { + set opt_withinansi 2 + } + } + # -- --- --- --- --- --- --- --- --- --- + 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"} { + #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] + + set padcharsize [punk::ansi::printing_length $padchar] + set pad_has_ansi [punk::ansi::ta::detect $padchar] + if {$block eq ""} { + #we need to treat as a line + set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + #TODO + #review - what happens when padchar has ansi, or the width would split a double-wide unicode char? + #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) + #we should use overtype with suitable replacement char (space?) for chopped double-wides + if {!$pad_has_ansi} { + return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] + } else { + set base [tcl::string::repeat " " $width] + return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + } + + #review - tcl format can only pad with zeros or spaces? + #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 + #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 + + 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 + foreach {pt ansi} $parts { + if {$pt ne ""} { + set has_nl [expr {[tcl::string::last \n $pt]>=0}] + if {$has_nl} { + set pt [tcl::string::map [list \r\n \n] $pt] + set partlines [split $pt \n] + } else { + set partlines [list $pt] + } + set last [expr {[llength $partlines]-1}] + set p 0 + foreach pl $partlines { + lappend line_chunks $pl + #incr line_len [punk::char::ansifreestring_width $pl] + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + } + if {$p != $last} { + #do padding + 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 + + #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars + if {[tcl::dict::exists $pad_cache $missing]} { + set pad [tcl::dict::get $pad_cache $missing] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + dict set pad_cache $missing $pad + } + switch -- $which-$opt_withinansi { + r-0 { + lappend line_chunks $pad + } + r-1 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + } + r-2 { + lappend line_chunks $pad + } + l-0 { + set line_chunks [linsert $line_chunks 0 $pad] + } + l-1 { + if {[lindex $line_chunks 0] eq ""} { + set line_chunks [linsert $line_chunks 2 $pad] + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + l-2 { + if {$lnum == 0} { + if {[lindex $line_chunks 0] eq ""} { + set line_chunks [linsert $line_chunks 2 $pad] + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + } + } + lappend lines [::join $line_chunks ""] + set line_chunks [list] + set line_len 0 + incr lnum + } + incr p + } + } else { + #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes + lappend line_chunks "" + } + #don't let trailing empty ansi affect the line_chunks length + if {$ansi ne ""} { + lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? + } + } + #pad last line + 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] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + } + #set pad [tcl::string::repeat $padchar $missing] + switch -- $which-$opt_withinansi { + r-0 { + lappend line_chunks $pad + } + r-1 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + } + r-2 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + #lappend line_chunks $pad + } + l-0 { + #if {[lindex $line_chunks 0] eq ""} { + # set line_chunks [linsert $line_chunks 2 $pad] + #} else { + # set line_chunks [linsert $line_chunks 0 $pad] + #} + set line_chunks [linsert $line_chunks 0 $pad] + } + l-1 { + #set line_chunks [linsert $line_chunks 0 $pad] + set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] + } + l-2 { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + } + lappend lines [::join $line_chunks ""] + return [::join $lines \n] + } + + #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single + #resulting list is no longer a valid ansisplit list + proc _insert_before_text_or_last_ansi {str ansisplits} { + if {[llength $ansisplits] == 1} { + #ansisplits was a split on plaintext only + return [list $str [lindex $ansisplits 0]] + } elseif {[llength $ansisplits] == 0} { + return [list $str] + } + if {[llength $ansisplits] %2 != 1} { + error "_insert_before_text_or_last_ansi ansisplits list is not a valid resultlist from an ansi split - must be odd number of elements pt,ansi,pt,ansi...pt" + } + set out [list] + set i 0 + set i_last_code [expr {[llength $ansisplits]-3}] ;#would normally be -2 - but our i is jumping to each pt - not every element + foreach {pt code} $ansisplits { + if {$pt ne ""} { + return [lappend out $str {*}[lrange $ansisplits $i end]] + } + if {$i == $i_last_code} { + return [lappend out $str {*}[lrange $ansisplits $i end]] + } + #code being empty can only occur when we have reached last pt + #we have returned by then. + lappend out $code + incr i 2 + } + error "_insert_before_text_or_last_ansi failed on input str:[ansistring VIEW $str] ansisplits:[ansistring VIEW $ansisplits]" + } + proc pad_test {block} { + set width [textblock::width $block] + set padtowidth [expr {$width + 10}] + 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] + + set t [textblock::list_as_table -columns 3 -return tableobject $testlist] + $t configure_column 0 -headers [list "ansi"] + $t configure_column 1 -headers [list "Left"] + $t configure_column 2 -headers [list "Right"] + $t configure -show_header 1 + puts stdout [$t print] + return $t + } + + proc pad_test_blocklist {blocklist args} { + set opts [tcl::dict::create\ + -description ""\ + -blockheaders ""\ + ] + foreach {k v} $args { + switch -- $k { + -description - -blockheaders { + tcl::dict::set opts $k $v + } + default { + error "pad_test_blocklist unrecognised option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + set opt_blockheaders [tcl::dict::get $opts -blockheaders] + set bheaders [tcl::dict::create] + if {$opt_blockheaders ne ""} { + set b 0 + foreach h $opt_blockheaders { + if {$b < [llength $blocklist]} { + tcl::dict::set bheaders $b $h + } + incr b + } + } + + set b 0 + set blockinfo [tcl::dict::create] + foreach block $blocklist { + set width [textblock::width $block] + tcl::dict::set blockinfo $b width $width + set padtowidth [expr {$width + 3}] + tcl::dict::set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] + tcl::dict::set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] + tcl::dict::set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] + tcl::dict::set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] + tcl::dict::set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] + tcl::dict::set blockinfo $b right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] + incr b + } + + set r0 [list "0"] + set r1 [list "1"] + set r2 [list "2"] + set r3 [list "column\ncolours"] + + #1 + #test without table padding + #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering + #(basically a mechanism to add extra resets at start and end of each line) + #dict for {b bdict} $blockinfo { + # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] + # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] + # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] + #} + + #2 - the more useful one? + tcl::dict::for {b bdict} $blockinfo { + lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] + lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] + lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] + lappend r3 "" "" + } + + set rows [concat $r0 $r1 $r2 $r3] + + set column_ansi [a+ web-white Web-Gray] + + set t [textblock::list_as_table -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows] + $t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi + set col 1 + tcl::dict::for {b bdict} $blockinfo { + if {[tcl::dict::exists $bheaders $b]} { + set hdr [tcl::dict::get $bheaders $b] + } else { + set hdr "Block $b" + } + $t configure_column $col -headers [list $hdr "Left"] -minwidth [expr {$padtowidth + 2}] + $t configure_column $col -header_colspans 2 -ansibase $column_ansi + incr col + $t configure_column $col -headers [list "-" "Right"] -minwidth [expr {$padtowidth + 2}] -ansibase $column_ansi + incr col + } + $t configure -show_header 1 + puts stdout [$t print] + return $t + } + proc pad_example {} { + set headers [list] + set blocks [list] + + lappend blocks "[textblock::testblock 4 rainbow]" + lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" + + lappend blocks "[textblock::testblock 4 rainbow][a]" + lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" + + lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" + lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}]" + lappend headers "rainbow 4x4\nno line resets\nnothing trailing" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" + lappend headers "rainbow 4x4\nno line resets\ntrailing reset" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" + lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" + + set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] + } + proc pad_example2 {} { + set headers [list] + set blocks [list] + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" + + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" + + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" + + set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] + } + + + #playing with syntax + + # pipealias ::textblock::join_width .= {list $lhs [tcl::string::repeat " " $w1] $rhs [tcl::string::repeat " " $w2]} {| + # /2,col1/1,col2/3 + # >} punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| + # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| + # >} punk::lib::list_as_lines -- $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} { + #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. + # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner + #" + 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 + } + set idx 0 + set fordata [list] + set colindices [list] + foreach b $blocks { + if {[punk::ansi::ta::detect $b]} { + lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] + } else { + lappend fordata "v($idx)" [split $b \n] + } + lappend colindices $idx + incr idx + } + set outlines [list] + foreach {*}$fordata { + set row {} + foreach colidx $colindices { + lappend row $v($colidx) + } + lappend outlines [::join $row ""] + } + return [::join $outlines \n] + } + #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed + #they may however still be 'ragged' ie differing line lengths + proc ::textblock::join {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 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] + 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] + } 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 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 " "] + } + lappend outlines $row + } + #puts stderr "--->outlines len: [llength $outlines]" + return [::join $outlines \n] + } + + proc ::textblock::trim {block} { + error "textblock::trim unimplemented" + set trimlines "" + } + + #pipealias ::textblock::join_right .= {list $lhs [tcl::string::repeat " " [width $lhs]] $rhs [tcl::string::repeat " " [width $rhs]]} {| + # /2,col1/1,col2/3 + # >} .=> punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| + # >} punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] + set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] + set testblock [textblock::testblock 15 rainbow] + set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] + set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] + } + + + proc example {args} { + set opts [tcl::dict::create -forcecolour 0] + foreach {k v} $args { + switch -- $k { + -forcecolour { + tcl::dict::set opts $k $v + } + default { + error "textblock::example unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]" + } + } + } + set opt_forcecolour 0 + if {[tcl::dict::get $opts -forcecolour]} { + set fc forcecolour + set opt_forcecolour 1 + } else { + set fc "" + } + set pleft [>punk . rhs] + set pright [>punk . lhs] + set prightair [>punk . lhs_air] + set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] + set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] + set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] + set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] + set RST [a] + set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] + set punks [textblock::join -- $pleft $pright] + set pleft_greenb $greenb$pleft$RST + set pright_redb $redb$pright$RST + set prightair_cyanb $cyanb$prightair$RST + set cpunks [textblock::join -- $pleft_greenb $pright_redb] + set out "" + append out $punks \n + append out $cpunks \n + append out [textblock::join -- $punks $cpunks] \n + 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 -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 -- $punkdeck " " $spantable] \n + #append out [textblock::frame -title gr $gr0] + append out [textblock::periodic -forcecolour $opt_forcecolour] + return $out + } + + proc example3 {{text "test\netc\nmore text"}} { + package require patternpunk + .= textblock::join -- [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join -- " " |> .=>1 textblock::join -- $text |> .=>1 textblock::join -- [>punk . rhs] |> .=>1 textblock::join -- [punk::lib::list_as_lines -- [lrepeat 7 " | "]] + } + proc example2 {{text "test\netc\nmore text"}} { + package require patternpunk + .= textblock::join\ + --\ + [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7 8]]\ + [>punk . lhs]\ + " "\ + $text\ + [>punk . rhs]\ + [punk::lib::list_as_lines -- [lrepeat 8 " | "]] + } + proc table {args} { + #todo - use punk::args + upvar ::textblock::class::opts_table_defaults toptdefaults + set defaults [tcl::dict::create\ + -rows [list]\ + -headers [list]\ + -return string\ + ] + + + set defaults [tcl::dict::merge $defaults $toptdefaults] ;# -title -frametype -show_header etc + set opts [tcl::dict::merge $defaults $args] + # -- --- --- --- + set opt_return [tcl::dict::get $opts -return] + set opt_rows [tcl::dict::get $opts -rows] + set opt_headers [tcl::dict::get $opts -headers] + # -- --- --- --- + set topts [tcl::dict::create] + set toptkeys [tcl::dict::keys $toptdefaults] + tcl::dict::for {k v} $opts { + if {$k in $toptkeys} { + tcl::dict::set topts $k $v + } + } + set t [textblock::class::table new {*}$topts] + + foreach h $opt_headers { + $t add_column -headers [list $h] + } + if {[$t column_count] == 0} { + if {[llength $opt_rows]} { + set r0 [lindex $opt_rows 0] + foreach c $r0 { + $t add_column + } + } + } + foreach r $opt_rows { + $t add_row $r + } + + + + if {$opt_return eq "string"} { + set result [$t print] + $t destroy + return $result + } else { + return $t + } + } + + proc frametype {f} { + #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] + switch -- $f { + 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 { + set is_custom_dict_ok 1 + if {[llength $f] %2 == 0} { + #custom dict may leave out keys - but cannot have unknown keys + foreach {k v} $f { + switch -- $k { + all - 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 + break + } + } + } + } else { + set is_custom_dict_ok 0 + } + if {!$is_custom_dict_ok} { + error "frame option -type must be one of known types: $::textblock::frametypes or a dictionary with any of keys all,hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + } + if {[dict exists $f all]} { + return [tcl::dict::create category custom type $f] + } else { + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + set custom_frame [tcl::dict::merge $default_custom $f] + return [tcl::dict::create category custom type $custom_frame] + } + } + } + } + variable framedef_cache [tcl::dict::create] + proc framedef {args} { + #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. + #e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy. + #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. + #the arc set can't even join to itself e.g with curved equivalents of T-like shapes + + #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. + variable framedef_cache + set cache_key $args + if {[tcl::dict::exists $framedef_cache $cache_key]} { + return [tcl::dict::get $framedef_cache $cache_key] + } + + + #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. + #It also means we can't specify checks on the option types etc + set opts [tcl::dict::create\ + -joins ""\ + -boxonly 0\ + ] + set bad_option 0 + 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 $a2 [lindex $args [incr i]] + } + -- { + set values [lrange $args $i+1 end] + break + } + default { + if {[string match -* $a]} { + set bad_option 1 + } else { + set values [lrange $args $i end] + } + break + } + } + } + set f [lindex $values 0] + set rawglobs [lrange $values 1 end] + if {![llength $rawglobs] || "all" in $rawglobs || "*" in $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] { + @id -id ::textblock::framedef + @cmd -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 -optional 1 -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 + } + + set joins [tcl::dict::get $opts -joins] + set boxonly [tcl::dict::get $opts -boxonly] + + + #sorted order down left right up + #1 x choose 4 + #4 x choose 3 + #6 x choose 2 + #4 x choose 1 + #15 combos + + set join_directions [list] + #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode + #e.g down-light, up-heavy + set join_targets [tcl::dict::create left "" down "" right "" up ""] + foreach jt $joins { + lassign [split $jt -] direction target + if {$target ne ""} { + tcl::dict::set join_targets $direction $target + } + lappend join_directions $direction + } + set join_directions [lsort -unique $join_directions] + set do_joins [::join $join_directions _] + + + switch -- $f { + "altg" { + #old style ansi escape sequences with alternate graphics page G0 + set hl [cd::hl] + set hlt $hl + set hlb $hl + set vl [cd::vl] + set vll $vl + set vlr $vl + set tlc [cd::tlc] + set trc [cd::trc] + set blc [cd::blc] + set brc [cd::brc] + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + #No join targets available to join altg to other box styles + switch -- $do_joins { + down { + #1 + set blc [punk::ansi::g0 t] ;#(ltj) + set brc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } left { + #2 + set tlc [punk::ansi::g0 w] ;#(ttj) + set blc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + right { + #3 + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 v] ;#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + up { + #4 + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + } + down_left { + #5 + set blc [punk::ansi::g0 n] ;#(fwj) + set tlc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + down_right { + #6 + set blc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 n] ;#(fwj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_up { + #7 + set blc [punk::ansi::g0 t] ;#(ltj) + set brc [punk::ansi::g0 u] ;#(rtj) + + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set hltj [punk::ansi::g0 v];#(btj) + } + left_right { + #8 + #from 2 + set tlc [punk::ansi::g0 w] ;#(ttj) + set blc [punk::ansi::g0 v] ;#(btj) + #from3 + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + left_up { + #9 + set tlc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 u] ;#(rtj) + set blc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + right_up { + #10 + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 v] ;#(btj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_left_right { + #11 + set blc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 w] ;#(ttj) + set tlc [punk::ansi::g0 w] ;#(ttj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + down_left_up { + #12 + set tlc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 u] ;#(rtj) + set brc [punk::ansi::g0 u] ;#(rtj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + down_right_up { + #13 + set tlc [punk::ansi::g0 t] ;#(ltj) + set blc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + left_right_up { + #14 + set tlc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 v] ;#(btj) + set brc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_left_right_up { + #15 + set tlc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + } + + + } + "ascii" { + 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 $hlt + #set hlbj $hlb + #set vllj $vll + #set vlrj $vlr + #ascii + is small - can reasonably be considered a join to anything? + set hltj + + set hlbj + + set vllj + + set vlrj + + #our corners are all + already - so we won't do anything for directions or targets + + } + "light" { + #unicode box drawing set + set hl [punk::char::charshort boxd_lhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_lv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ldr] + set trc [punk::char::charshort boxd_ldl] + set blc [punk::char::charshort boxd_lur] + set brc [punk::char::charshort boxd_lul] + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #15 combos + #sort order: down left right up + #ltj,rtj,ttj,btj e.g left T junction etc. + #Look at from the perspective of a frame/table outline with a clean border and arms pointing inwards + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'light' + foreach dir {down left right up} { + 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 + } + ascii - altg - arc { + set target$dir light + } + heavy { + set target$dir $target + } + default { + set target$dir other + } + } + } + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + heavy { + set blc [punk::char::charshort boxd_dhrul] ;#\u251f down hieavy and right up light (ltj) + set brc \u2527 ;#boxd_dhlul down heavy and left up light (rtj) + set hlbj \u2530 ;# down heavy (ttj) + } + light { + set blc \u251c ;#[punk::char::charshort boxd_lvr] light vertical and right (ltj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set hlbj \u252c ;# (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + heavy { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + } + light { + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set vllj \u2524 ;# (rtj) + } + } + } + right { + #3 + switch -- $targetright { + heavy { + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + set vlrj \u251d;#right heavy (ltj) + } + light { + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set vlrj \u251c;# (ltj) + } + } + } + up { + #4 + switch -- $targetup { + heavy { + set tlc \u251e ;#up heavy (ltj) + set trc \u2526 ;#up heavy (rtj) + } + light { + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + other-light { + set blc \u2534 ;#(btj) + set tlc \u252c ;#(ttj) + #brc - default corner + set vllj \u2524 ;# (rtj) + } + other-other { + #default corners + } + other-heavy { + set blc \u2535 ;# heavy left (btj) + set tlc \u252d ;#heavy left (ttj) + #brc default corner + set vllj \u2525 ;# heavy left (rtj) + } + heavy-light { + set blc \u2541 ;# heavy down (fwj) + set tlc \u252c ;# light (ttj) + set brc \u2527 ;# heavy down (rtj) + set vllj \u2524 ;# (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + heavy-other { + set blc \u251f ;#heavy down (ltj) + #tlc - default corner + set brc \u2527 ;#heavy down (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + heavy-heavy { + set blc \u2545 ;#heavy down and left (fwj) + set tlc \u252d ;#heavy left (ttj) + set brc \u2527 ;#heavy down (rtj) + set vllj \u2525 ;# heavy left (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + light-light { + set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set tlc \u252c ;# boxd_ldhz (ttj) + set brc \u2524 ;# boxd_lvl light vertical and left(rtj) + set vllj \u2524 ;# (rtj) + set hlbj \u252c ;# (ttj) + } + light-other { + set blc \u251c ;# (ltj) + #tlc - default corner + set brc \u2524 ;# boxd_lvl (rtj) + set hlbj \u252c ;# (ttj) + } + light-heavy { + set blc \u253d ;# heavy left (fwj) + set tlc \u252d ;# heavy left (ttj) + set brc \u2524 ;# light (rtj) + set vllj \u2525 ;# heavy left (rtj) + set hlbj \u252c ;# (ttj) + } + default { + set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set tlc \u252c ;# [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc \u2524 ;# [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + } + } + down_right { + #6 + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + down_up { + #7 + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + left_right { + #8 + #from 2 + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + #from3 + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + + + switch -- $targetleft-$targetright { + heavy-light { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + set vlrj \u251c;#right light (ltj) + } + heavy-other { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + } + heavy-heavy { + set vllj \u2525 ;# left heavy (rtj) + set vlrj \u251d;#right heavy (ltj) + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + } + light-heavy { + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + set vlrj \u251d;#right heavy (ltj) + set vllj \u2524 ;# left light (rtj) + } + light-other { + set vllj \u2524 ;# left light (rtj) + } + light-light { + set vllj \u2524 ;# left light (rtj) + set vlrj \u251c;#right light (ltj) + } + } + #set vllj \u2525 ;# left heavy (rtj) + #set vllj \u2524 ;# left light (rtj) + #set vlrj \u251d;#right heavy (ltj) + #set vlrj \u251c;#right light (ltj) + } + left_up { + #9 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + } + right_up { + #10 + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + } + down_left_right { + #11 + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + + } + down_left_up { + #12 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + + } + down_right_up { + #13 + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + left_right_up { + #14 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + + } + down_left_right_up { + #15 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + } + #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 + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_hv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_hdr] + set trc [punk::char::charshort boxd_hdl] + set blc [punk::char::charshort boxd_hur] + set brc [punk::char::charshort boxd_hul] + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'heavy' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - heavy { + set target$dir heavy + } + light - ascii - altg - arc { + set target$dir light + } + default { + set target$dir other + } + } + } + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + light { + set blc [punk::char::charshort boxd_dlruh] ;#\u2521 down light and right up heavy (ltj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) + set hlbj \u252F ;#down light (ttj) + } + heavy { + set blc [punk::char::charshort boxd_hvr] ;# (ltj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set hlbj \u2533 ;# down heavy (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + light { + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) + set vllj \u2528 ;# left light (rtj) + } + heavy { + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + set vllj \u252b ;#(rtj) + } + } + } + right { + #3 + switch -- $targetright { + light { + set trc [punk::char::charshort boxd_rlldh] ;#\u2531 Right Light and Left Down Heavy (ttj) + set brc [punk::char::charshort boxd_rlluh] ;#\u2539 Right Light and Left Up Heavy(btj) + set vlrj \u2520 ;#right light (ltj) + } + heavy { + set trc [punk::char::charshort boxd_hdhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_huhz] ;# (btj) + set vlrj \u2523 ;# (ltj) + } + } + } + up { + #4 + switch -- $targetup { + light { + set tlc [punk::char::charshort boxd_ulrdh] ;#\u2522 Up Light and Right Down Heavy (ltj) + set trc [punk::char::charshort boxd_ulldh] ;#\u252a Up Light and Left Down Heavy (rtj) + set hltj \u2537 ;# up light (btj) + } + heavy { + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + set hltj \u253b ;# (btj) + } + } + } + down_left { + #down_left is the main join type used for 'L' shaped cell border table building where we boxlimit to {vll hlb blc} + #5 + switch -- down-$targetdown-left-$targetleft { + down-light-left-heavy { + set blc [punk::char::charshort boxd_dluhzh] ;#down light and up horizontal heavy (fwj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) (at tlc down stays heavy) + set hlbj \u252F ;# down light (ttj) + set vllj \u252b ;#(rtj) + } + down-heavy-left-light { + set blc [punk::char::charshort boxd_llrvh] ;# left light and right Vertical Heavy (fwj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) (at brc left must stay heavy) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set hlbj \u2533 ;# down heavy (ttj) + set vllj \u2528 ;# left light (rtj) + } + down-light-left-light { + set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) + set hlbj \u252F ;# down light (ttj) + set vllj \u2528 ;# left light (rtj) + } + down-heavy-left-heavy { + set blc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set hlbj \u2533 ;#(ttj) + set vllj \u252b ;#(rtj) + } + down-other-left-heavy { + set blc \u253b ;#boxd_huhz Heavy Up and Horizontal (btj) + #leave brc default corner + set tlc \u2533 ;#hdhz Heavy Down and Horizontal (ttj) + + set vllj \u252b ;#(rtj) + } + down-other-left-light { + set blc \u253a ;#llruh Left Light and Right Up Heavy (btj) + #leave brc default corner + set tlc \u2532 ;#llrdh Left Light and Right Down Heavy (ttj) + + set vllj \u2528 ;# left light (rtj) + } + down-heavy-left-other { + set blc \u2523 ;#hvr Heavy Vertical and Right (ltj) + set brc \u252b ;#hvl Heavy Veritcal and Left (rtj) + #leave tlc default corner + + set hlbj \u2533 ;#(ttj) + } + down-light-left-other { + set blc \u2521 ;#dlruh Down Light and Right Up Heavy (ltj) + set brc \u2529 ;#dlluh Down Light and Left Up Heavy (rtj) + #leave tlc default corner + + set hlbj \u252F ;# down light (ttj) + } + } + } + down_right { + #6 + set blc [punk::char::charshort boxd_hvr] ;# (ltj) (blc right&up stay heavy) + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) (tlc down&left stay heavy) + set brc [punk::char::charshort boxd_hvhz] ;# (fwj) (brc left&up heavy) + } + down_up { + #7 + set blc [punk::char::charshort boxd_hvr] ;# (ltj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + } + left_right { + #8 + #from 2 + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + #from3 + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) + set brc [punk::char::charshort boxd_huhz] ;# (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) + } + 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) + } + 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) + + } + 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) + + } + 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) + } + 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) + + } + 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) + } + } + } + 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 + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551 + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554 + set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557 + set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A + set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + # \u256c (fwj) + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'double' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - double { + set target$dir double + } + light { + set target$dir light + } + default { + set target$dir other + } + } + } + + #unicode provides no joining for double to anything else + #better to leave a gap by using default double corners if join target is not empty or double + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + double { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + set hlbj \u2566 ;# (ttj) + } + light { + set hlbj \u2564 ;# down light (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + double { + set tlc \u2566 ;# (ttj) + set blc \u2569 ;# (btj) + set vllj \u2563 ;# (rtj) + } + light { + set vllj \u2562 ;# light left (rtj) + } + } + } + right { + #3 + switch -- $targetright { + double { + set trc \u2566 ;# (ttj) + set brc \u2569 ;# (btj) + } + light { + set vlrj \u255F ;# light right (ltj) + } + } + } + up { + #4 + switch -- $targetup { + double { + set tlc \u2560 ;# (ltj) + set trc \u2563 ;# (rtj) + set hltj \u2569 ;# (btj) + } + light { + set hltj \u2567 ;#up light (btj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + double-double { + set blc \u256c ;# (fwj) + set brc \u2563 ;# (rtj) + set tlc \u2566 ;# (ttj) + set hlbj \u2566 ;# (ttj) + } + double-light { + #no corner joins treat corners like 'other' + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + + set hlbj \u2566 ;# (ttj) + set vllj \u2562 ;# light left (rtj) + + } + double-other { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + #leave tlc as ordinary double corner + } + light-double { + + set vllj \u2563 ;# (rtj) + set hlbj \u2564 ;# light down (ttj) + + } + light-light { + + set vllj \u2562 ;# light left (rtj) + set hlbj \u2564 ;# light down (ttj) + } + other-light { + set vllj \u2562 ;# light left (rtj) + } + other-double { + set blc \u2569 ;# (btj) + #leave brc as ordinary double corner + set tlc \u2566 ;# (ttj) + } + } + } + down_right { + #6 + switch -- $targetdown-$targetright { + double-double { + set blc \u2560 ;# (ltj) + set trc \u2566 ;# (ttj) + set brc \u256c ;# (fwj) + set hlbj \u2566 ;# (ttj) + } + double-other { + set blc \u2560 ;# (ltj) + #leave trc default + set brc \u2563 ;# (rtj) + } + other-double { + #leave blc default + set trc \u2566 ;# (ttj) + set brc \u2569 ;#(btj) + } + } + } + down_up { + #7 + switch -- $targetdown-$targetup { + double-double { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + set tlc \u2560 ;# (ltj) + set trc \u2563 ;# (rtj) + set hltj \u2569 ;# (btj) + set hlbj \u2566 ;# (ttj) + } + } + } + left_right { + #8 + + #from 2 + #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_ddhz] ;# (ttj) + set brc [punk::char::charshort boxd_duhz] ;# (btj) + } + left_up { + #9 + 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_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_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_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_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_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_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) + } + } + + } + "arc" { + #unicode box drawing set + + + set hl [punk::char::charshort boxd_lhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_lv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D + set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E + set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 + set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'arc' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - arc { + set target$dir self + } + default { + set target$dir other + } + } + } + + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + self { + set blc \u251c ;# *light (ltj) + #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left + #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable + #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal + + #set brc \u2524 ;# *light(rtj) + #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) + } + } + } + left { + #2 + switch -- $targetleft { + self { + set tlc \u252c ;# *light(ttj) - need a low positioned curved y shape - nothing apparent + #set blc \u2144 ;# (btj) - upside down y - positioning too low for arc + set blc \u2534 ;# *light (btj) + } + } + } + right { + #3 + switch -- $targetright { + self { + set trc \u252c ;# *light (ttj) + #set brc \u2144 ;# (btj) + set brc \u2534 ;# *light (btj) + } + } + } + up { + #4 + switch -- $targetup { + self { + set tlc \u251c ;# *light (ltj) + set trc \u2524 ;# *light(rtj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + self-self { + #set blc \u27e1 ;# white concave-sided diamond - positioned too far right + #set blc \u27e3 ;# concave sided diamond with rightwards tick - positioned too low, too right - big gaps + #set blc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right + set brc \u2524 ;# *light (rtj) + set tlc \u252c ;# *light (ttj) + } + self-other { + #set blc \u2560 ;# (ltj) + #set brc \u2563 ;# (rtj) + #leave tlc as ordinary double corner + } + other-self { + #set blc \u2569 ;# (btj) + #leave brc as ordinary double corner + #set tlc \u2566 ;# (ttj) + } + } + } + down_right { + switch -- $targetdown-$targetright { + self-self { + #set brc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right + set trc \u252c ;# (ttj) + set blc \u2524 ;# (rtj) + } + } + } + } + } + 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 + set hlb \u2594 ;# upper one eighth block + set vll \u258f ;# left one eighth block + set vlr \u2595 ;# right one eighth block + set tlc \u2581 ;# lower one eighth block + set trc \u2581 ;# lower one eighth block + set blc \u2594 ;# upper one eighth block + set brc \u2594 ;# upper one eight block + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + } + block2 { + #the resultant table will have text appear towards top of each box + #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps + set hlt \u2594 ;# upper one eighth block + set hlb \u2581 ;# lower one eighth block + set vlr \u2595 ;# right one eighth block + set vll \u258f ;# left one eighth block + + #some terminals (on windows as at 2024) miscount width of these single-width blocks internally + #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) + #This was fixed in windows-terminal based systems (2021) but persists in others. + #https://github.com/microsoft/terminal/issues/11694 + set tlc \U1fb7d ;#legacy block + set trc \U1fb7e ;#legacy block + set blc \U1fb7c ;#legacy block + set brc \U1fb7f ;#legacy block + + if {[punk::console::check::has_bug_legacysymbolwidth]} { + #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems + set sp \u00a0 ;#non breaking space (plain space may act transparent in some use cases) + set tlc $sp + set trc $sp + set blc $sp + set brc $sp + } + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + } + block2hack { + #the resultant table will have text appear towards top of each box + #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps + set hlt \u2594 ;# upper one eighth block + set hlb \u2581 ;# lower one eighth block + set vlr \u2595 ;# right one eighth block + set vll \u258f ;# left one eighth block + + #see comments in block2 regarding the problems in some terminals that this *may* hack around to some extent. + #the caller probably only needs block2hack if block2 doesn't work + + #1) + #review - this hack looks sort of promising - but overtype::renderline needs fixing ? + #set tlc \U1fb7d\b ;#legacy block + #set trc \U1fb7e\b ;#legacy block + #set blc \U1fb7c\b ;#legacy block + #set brc \U1fb7f\b ;#legacy block + + #2) - works on cmd.exe and some others + # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones + #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) + #this hack has a reasonable chance of working + #except that the punk overtype library does recognise PMs + #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! + #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. + set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block + set trc \U1fb7e\x1b^\b\x1b\\ ;#legacy block + set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block + set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + } + block { + set hlt \u2580 ;#upper half + set hlb \u2584 ;#lower half + set vll \u258c ;#left half + set vlr \u2590 ;#right half + + set tlc \u259b ;#upper left corner half + set trc \u259c + set blc \u2599 + set brc \u259f + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + } + default { + #set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + if {"all" in [dict keys $f]} { + set A [dict get $f all] + set default_custom [tcl::dict::create hl $A vl $A tlc $A trc $A blc $A brc $A] + } + if {[llength $f] % 2} { + #todo - retrieve usage from punk::args + error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $::textblock::frametypes and does not appear to be a dictionary for a custom frametype" + } + #unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults + dict for {k v} $f { + switch -- $k { + all - hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} + default { + error "textblock::frametype '$f' has unknown element '$k'" + } + } + } + #verified keys - safe to extract as vars + set custom_frame [tcl::dict::merge $default_custom $f] + tcl::dict::with custom_frame {} ;#extract keys as vars + #longer j vars must be after their more specific counterparts in the list being processed by foreach + foreach t {hlt hlb vll vlr hltj hlbj vllj vlrj} { + if {[tcl::dict::exists $custom_frame $t]} { + set $t [tcl::dict::get $custom_frame $t] + } else { + #set more explicit type to it's more general counterpart if it's missing + #e.g hlt -> hl + #e.g hltj -> hlt + set $t [set [string range $t 0 end-1]] + } + } + #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set + #horizontal and vertical bar joins - key/variable ends with 'j' + } + } + if {$boxonly} { + set result [tcl::dict::create\ + tlc $tlc hlt $hlt trc $trc\ + vll $vll vlr $vlr\ + blc $blc hlb $hlb brc $brc\ + ] + } else { + set result [tcl::dict::create\ + tlc $tlc hlt $hlt trc $trc\ + vll $vll vlr $vlr\ + blc $blc hlb $hlb brc $brc\ + hltj $hltj\ + hlbj $hlbj\ + vllj $vllj\ + vlrj $vlrj\ + ] + } + 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] + + punk::args::define { + @id -id ::textblock::frame_cache + @cmd -name textblock::frame_cache -help\ + "Display or clear the frame cache." + -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 + } + proc frame_cache {args} { + set argd [punk::args::get_by_id ::textblock::frame_cache $args] + set action [dict get $argd opts -action] + + if {$action ni [list clear ""]} { + error "frame_cache action '$action' not understood. Valid actions: clear" + } + variable frame_cache + if {[dict get $argd opts -pretty]} { + set out [pdict -chan none frame_cache */*] + } else { + set out "" + if {[catch { + set termwidth [tcl::dict::get [punk::console::get_size] columns] + }]} { + set termwidth 80 + } + + tcl::dict::for {k v} $frame_cache { + lassign $v _f frame _used used + set fwidth [textblock::widthtopline $frame] + #review - are cached frames uniform width lines? + #set fwidth [textblock::width $frame] + set frameinfo "$k used:$used " + set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] + if {$allinone_width >= $termwidth} { + #split across 2 lines + append out "$frameinfo\n" + append out $frame \n + } else { + append out [textblock::join -- $frameinfo $frame]\n + } + append out \n ;# frames used to build tables often have joins - keep a line in between for clarity + } + } + if {$action eq "clear"} { + set frame_cache [tcl::dict::create] + append out \nCLEARED + } + return $out + } + + + variable FRAMETYPES + set FRAMETYPES [textblock::frametypes] + variable EG + set EG [a+ brightblack] + variable RST + set RST [a] + + proc frame_samples {} { + set FRAMETYPELABELS [dict create] + if {[info commands ::textblock::frame] ne ""} { + foreach ft [frametypes] { + dict set FRAMETYPELABELS $ft [textblock::frame -checkargs 0 -type $ft " "] + } + } + set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] + return $FRAMETYPELABELS + } + #proc EG {} "return {[a+ brightblack]}" + #make EG fetch from SGR cache so as to abide by colour off/on + proc EG {} { + a+ brightblack + } + #proc RST {} "return {\x1b\[m}" + proc RST {} { + return "\x1b\[m" + } + + #catch 22 for -choicelabels - need some sort of lazy evaluation + # ${[textblock::frame_samples]} + + #todo punk::args alias for centre center etc? + punk::args::define -dynamic 1 { + @id -id ::textblock::frame + @cmd -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 {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ + -choicelabels { + ${[textblock::frame_samples]} + }\ + -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. + ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::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. + ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${[textblock::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. + ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::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. + ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" + } + + #options before content argument - which is allowed to be absent + #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. + # + #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) + # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? + #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand + #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it + # - but we would need to maintain support for the rendered-string based operations too. + proc frame {args} { + variable frametypes + variable use_hash + + #counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var + set opts [tcl::dict::create\ + -etabs 0\ + -type light\ + -boxlimits [list hl vl tlc blc trc brc]\ + -boxmap {}\ + -joins [list]\ + -title ""\ + -subtitle ""\ + -width ""\ + -height ""\ + -ansiborder ""\ + -ansibase ""\ + -blockalign "centre"\ + -textalign "left"\ + -ellipsis 1\ + -usecache 1\ + -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 has_contents 0 + set optlist $args ;#initial only - content will be removed + #no solo opts for frame + if {[llength $args] %2 == 0} { + if {[lindex $args end-1] eq "--"} { + set contents [lpop optlist end] + set has_contents 1 + lpop optlist end ;#drop the end-of-opts flag + } else { + set optlist $args + set contents "" + } + } else { + set contents [lpop optlist 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} $optlist { + 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 + - -checkargs { + tcl::dict::set opts $k2 $v + } + default { + #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 + #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame + if {[llength $args] != 1 && (!$opts_ok || $check_args)} { + set argd [punk::args::get_by_id ::textblock::frame $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_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 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 opt_textalign [tcl::dict::get $opts -textalign] + + 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 + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + + lassign [textblock::frametype $opt_type] _cat category _type ftype + if {$category eq "custom"} { + set custom_frame $ftype + set frameset "custom" + set framedef $custom_frame + } else { + #category = predefined + set frameset $ftype ;# light,heavy etc + set framedef $ftype + } + + #if check_args? + + + #REVIEW - now done in framedef? + #set join_directions [list] + ##targets - light,heavy (double?) - seem to be some required glyphs missing from unicode + ##e.g down-light, up-heavy + #set join_targets [tcl::dict::create left "" down "" right "" up ""] + #foreach jt $opt_joins { + # lassign [split $jt -] direction target + # if {$target ne ""} { + # tcl::dict::set join_targets $direction $target + # } + # lappend join_directions $direction + #} + #set join_directions [lsort -unique $join_directions] + #set do_joins [::join $join_directions _] + + + + + # -- --- --- --- --- --- + + if {$has_contents} { + if {[tcl::string::last \t $contents] >= 0} { + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + if {$opt_etabs} { + #todo + set contents [textutil::tabify::untabify2 $contents $tw] + } + } + set contents [tcl::string::map {\r\n \n} $contents] + if {$opt_crm_mode} { + if {$opt_height eq ""} { + set h [textblock::height $contents] + } else { + set h [expr {$opt_height -2}] + } + if {$opt_width eq ""} { + set w [textblock::width $contents] + } else { + 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 + } + } else { + set actual_contentwidth 0 + set actual_contentheight 0 + } + + if {$opt_title ne ""} { + set titlewidth [punk::ansi::printing_length $opt_title] + set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}] + } else { + set titlewith 0 + set content_or_title_width $actual_contentwidth + } + #opt_subtitle ?? + + if {$opt_width eq ""} { + set frame_inner_width $content_or_title_width + } else { + set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default + } + + if {$opt_height eq ""} { + set frame_inner_height $actual_contentheight + } else { + set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default + } + if {$frame_inner_height == 0 && $frame_inner_width == 0} { + set has_contents 0 + } + #todo - render it with vertical overflow so we can process ansi moves? + #set linecount [textblock::height $contents] + set linecount $frame_inner_height + + # -- --- --- --- --- --- --- --- --- + variable frame_cache + #review - custom frame affects frame_inner_width - exclude from caching? + #set cache_key [concat $optlist $frame_inner_width $frame_inner_height] + #jmn + #set hashables [concat $optlist $frame_inner_width $frame_inner_height] + set hashables [list {*}$optlist $frame_inner_width $frame_inner_height] + + + switch -- $use_hash { + sha1 { + package require sha1 + set hash [sha1::sha1 [encoding convertto utf-8 $hashables]] + } + md5 { + package require md5 + if {[package vsatisfies [package present md5] 2- ] } { + set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review + } else { + set hash [md5::md5 [encoding convertto utf-8 $hashables]] + } + } + none { + set hash $hashables + } + } + + set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth" + #should be in a unicode private range different to that used in table construction + #e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts + #also supplementary private use blocks + #however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult) + #U+F0000 -> U+FFFD + #U+100000 -> U+10FFFD + #FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy) + #should be something someone is unlikely to use as part of a custom frame character. + #ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better) + #As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string + #terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like. + #e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never" + #review - we could consider wasting a few cycles to check for a conflict and use a different FSUB + set FSUB \uF2DD + + + #this occurs commonly in table building with colspans - review + if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { + set usecache 0 + #set buildcache 0 ;#comment out for debug/analysis so we can see + #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" + set cache_key [a+ Web-red web-white]$cache_key[a] + } + if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { + #colourise cache_key to warn + if {$actual_contentwidth == 0} { + #we can still substitute with right length + set cache_key [a+ Web-steelblue web-black]$cache_key[a] + } else { + #actual_contentwidth is narrower than frame - check template's patternwidth + if {[tcl::dict::exists $frame_cache $cache_key]} { + set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] + } else { + set cache_patternwidth $actual_contentwidth + } + if {$actual_contentwidth < $cache_patternwidth} { + set usecache 0 + set cache_key [a+ Web-orange web-black]$cache_key[a] + } elseif {$actual_contentwidth == $cache_patternwidth} { + #set usecache 1 + } else { + #actual_contentwidth > pattern + set usecache 0 + set cache_key [a+ Web-red web-black]$cache_key[a] + } + } + } + + #JMN debug + #set usecache 0 + + set is_cached 0 + if {$usecache && [tcl::dict::exists $frame_cache $cache_key]} { + set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] + set template [tcl::dict::get $frame_cache $cache_key frame] + set used [tcl::dict::get $frame_cache $cache_key used] + tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record + set is_cached 1 + } + + + # -- --- --- --- --- --- --- --- --- + if {!$is_cached} { + # -- --- --- --- --- + # -- --- --- --- --- + set is_joins_ok 1 + foreach v $opt_joins { + lassign [split $v -] direction target + switch -- $direction { + left - right - up - down {} + default { + set is_joins_ok 0 + break + } + } + switch -- $target { + "" - 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 + } + } + } + if {!$is_joins_ok} { + 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 + 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 + } + } + } + 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,hltj,hlbj,vllj,vlrj" + } + # -- --- --- --- --- --- + #these are all valid commands for overtype:: + switch -- $opt_textalign { + left - right - centre - center {} + default { + error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" + } + } + # -- --- --- --- --- --- + switch -- $opt_blockalign { + left - right - centre - center {} + default { + error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign" + } + } + # -- --- --- --- --- + # -- --- --- --- --- + set is_boxlimits_ok 1 + set exact_boxlimits [list] + foreach v $opt_boxlimits { + switch -- $v { + hl { + lappend exact_boxlimits hlt hlb + } + vl { + lappend exact_boxlimits vll vlr + } + hlt - hlb - vll - vlr - tlc - trc - blc - brc { + lappend exact_boxlimits $v + } + default { + #k not in custom_keys + set is_boxlimits_ok 0 + break + } + } + } + #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" + } + set exact_boxlimits [lsort -unique $exact_boxlimits] + # -- --- --- --- --- --- + + + set rst [a] + #set column [tcl::string::repeat " " $frame_inner_width] ;#default - may need to override for custom frame + set underlayline [tcl::string::repeat " " $frame_inner_width] + set underlay [::join [lrepeat $linecount $underlayline] \n] + + + set vll_width 1 ;#default for all except custom (printing width) + set vlr_width 1 + + set framedef [textblock::framedef -joins $opt_joins $framedef] + tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars + + #puts "---> $opt_boxmap" + #review - we handle double-wide in custom frames - what about for boxmaps? + tcl::dict::for {boxelement sub} $opt_boxmap { + if {$boxelement eq "vl"} { + set vll $sub + set vlr $sub + set hl $sub + } elseif {$boxelement eq "hl"} { + set hlt $sub + set hlb $sub + set hl $sub + } else { + set $boxelement $sub + } + } + + switch -- $frameset { + custom { + #REVIEW - textblock::table assumes that at least the vl elements are 1-wide + #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though + #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely + set vll_width [punk::ansi::printing_length $vll] + set hlb_width [punk::ansi::printing_length $hlb] + set hlt_width [punk::ansi::printing_length $hlt] + + set vlr_width [punk::ansi::printing_length $vlr] + + set tlc_width [punk::ansi::printing_length $tlc] + set trc_width [punk::ansi::printing_length $trc] + set blc_width [punk::ansi::printing_length $blc] + set brc_width [punk::ansi::printing_length $brc] + + + set framewidth [expr {$frame_inner_width + 2}] ;#reverse default assumption + if {$opt_width eq ""} { + #width wasn't specified - so user is expecting frame to adapt to title/contents + #content shouldn't truncate because of extra wide frame + #review - punk::console::get_size ? wrapping? quite hard to support with colspans + set frame_inner_width $content_or_title_width + set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width + set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] + } else { + set frame_inner_width [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated + set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}] + set bbarwidth [expr {$opt_width - $blc_width - $brc_width}] + } + #set column [tcl::string::repeat " " $frame_inner_width] + set underlayline [tcl::string::repeat " " $frame_inner_width] + set underlay [::join [lrepeat $linecount $underlayline] \n] + #cache? + + if {$hlt_width == 1} { + set tbar [tcl::string::repeat $hlt $tbarwidth] + } else { + #possibly mixed width chars that make up hlt - tcl::string::range won't get width right + set blank [tcl::string::repeat " " $tbarwidth] + if {$hlt_width > 0} { + set count [expr {($tbarwidth / $hlt_width) + 1}] + } else { + set count 0 + } + set tbar [tcl::string::repeat $hlt $count] + #set tbar [tcl::string::range $tbar 0 $tbarwidth-1] + set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character + } + if {$hlb_width == 1} { + set bbar [tcl::string::repeat $hlb $bbarwidth] + } else { + set blank [tcl::string::repeat " " $bbarwidth] + if {$hlb_width > 0} { + set count [expr {($bbarwidth / $hlb_width) + 1}] + } else { + set count 0 + } + set bbar [tcl::string::repeat $hlb $count] + #set bbar [tcl::string::range $bbar 0 $bbarwidth-1] + set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] + } + } + altg { + set tbar [tcl::string::repeat $hlt $frame_inner_width] + set tbar [cd::groptim $tbar] + set bbar [tcl::string::repeat $hlb $frame_inner_width] + set bbar [cd::groptim $bbar] + } + default { + set tbar [tcl::string::repeat $hlt $frame_inner_width] + set bbar [tcl::string::repeat $hlb $frame_inner_width] + + } + } + + set leftborder 0 + set rightborder 0 + set topborder 0 + set bottomborder 0 + # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + #puts "----->$exact_boxlimits" + foreach lim $exact_boxlimits { + switch -- $lim { + hlt { + set topborder 1 + } + hlb { + set bottomborder 1 + } + vll { + set leftborder 1 + } + vlr { + set rightborder 1 + } + tlc { + set topborder 1 + set leftborder 1 + } + trc { + set topborder 1 + set rightborder 1 + } + blc { + set bottomborder 1 + set leftborder 1 + } + brc { + set bottomborder 1 + set rightborder 1 + } + } + } + if {$opt_width ne "" && $opt_width < 2} { + set rightborder 0 + } + #keep lhs/rhs separate? can we do vertical text on sidebars? + set lhs [tcl::string::repeat $vll\n $linecount] + set lhs [tcl::string::range $lhs 0 end-1] + set rhs [tcl::string::repeat $vlr\n $linecount] + set rhs [tcl::string::range $rhs 0 end-1] + + + if {$opt_ansiborder ne ""} { + set tbar $opt_ansiborder$tbar$rst + set bbar $opt_ansiborder$bbar$rst + set tlc $opt_ansiborder$tlc$rst + set trc $opt_ansiborder$trc$rst + set blc $opt_ansiborder$blc$rst + set brc $opt_ansiborder$brc$rst + + set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out + set rhs $opt_ansiborder$rhs$rst + } + + #boxlimits used for partial borders in table generation + set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] + set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] + foreach lim $unspecified_limits { + switch -- $lim { + vll { + set blank_vll [tcl::string::repeat " " $vll_width] + set lhs [tcl::string::repeat $blank_vll\n $linecount] + set lhs [tcl::string::range $lhs 0 end-1] + } + vlr { + set blank_vlr [tcl::string::repeat " " $vlr_width] + set rhs [tcl::string::repeat $blank_vlr\n $linecount] + set rhs [tcl::string::range $rhs 0 end-1] + } + hlt { + set bar_width [punk::ansi::printing_length $tbar] + set tbar [tcl::string::repeat " " $bar_width] + } + tlc { + set tlc_width [punk::ansi::printing_length $tlc] + set tlc [tcl::string::repeat " " $tlc_width] + } + trc { + set trc_width [punk::ansi::printing_length $trc] + set trc [tcl::string::repeat " " $trc_width] + } + hlb { + set bar_width [punk::ansi::printing_length $bbar] + set bbar [tcl::string::repeat " " $bar_width] + } + blc { + set blc_width [punk::ansi::printing_length $blc] + set blc [tcl::string::repeat " " $blc_width] + } + brc { + set brc_width [punk::ansi::printing_length $brc] + set brc [tcl::string::repeat " " $brc_width] + } + } + } + + if {$opt_title ne ""} { + set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off + } else { + set topbar $tbar + } + if {$opt_subtitle ne ""} { + set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off + } else { + set bottombar $bbar + } + if {$opt_ansibase eq ""} { + set rstbase [a] + } else { + set rstbase [a]$opt_ansibase + } + + if {$opt_title ne ""} { + #title overrides -boxlimits for topborder + set topborder 1 + } + set fs "" + set fscached "" + set cache_patternwidth 0 + #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? + if {$topborder} { + if {$leftborder && $rightborder} { + append fs $tlc$topbar$trc + } else { + if {$leftborder} { + append fs $tlc$topbar + } elseif {$rightborder} { + append fs $topbar$trc + } else { + append fs $topbar + } + } + } + append fscached $fs + if {$has_contents || $opt_height > 2} { + #if {$topborder && $fs ne "xx"} { + # append fs \n + #} + if {$topborder} { + append fs \n + append fscached \n + } + switch -- $opt_textalign { + right {set pad "left"} + left {set pad "right"} + default {set pad $opt_textalign} + } + #set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1] + #set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents] + + set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth] + set cache_patternwidth $actual_contentwidth + set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] + set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] + #after overtype::block - our actual patternwidth may be less + set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] + + if {$leftborder && $rightborder} { + #set bodyparts [list $lhs $inner $rhs] + set cache_bodyparts [list $lhs $cache_inner $rhs] + } else { + if {$leftborder} { + #set bodyparts [list $lhs $inner] + set cache_bodyparts [list $lhs $cache_inner] + } elseif {$rightborder} { + #set bodyparts [list $inner $rhs] + set cache_bodyparts [list $cache_inner $rhs] + } else { + #set bodyparts [list $inner] + set cache_bodyparts [list $cache_inner] + } + } + #set body [textblock::join -- {*}$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 + } + + if {$opt_height eq "" || $opt_height > 1} { + if {$opt_subtitle ne ""} { + #subtitle overrides boxlimits for bottomborder + set bottomborder 1 + } + if {$bottomborder} { + if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { + #append fs \n + append fscached \n + } + if {$leftborder && $rightborder} { + #append fs $blc$bottombar$brc + append fscached $blc$bottombar$brc + } else { + if {$leftborder} { + #append fs $blc$bottombar + append fscached $blc$bottombar + } elseif {$rightborder} { + #append fs $bottombar$brc + append fscached $bottombar$brc + } else { + #append fs $bottombar + append fscached $bottombar + } + } + } + } + set template $fscached + ;#end !$is_cached + } + + + + + #use the same mechanism to build the final frame - whether from cache or template + if {$actual_contentwidth == 0} { + set fs [tcl::string::map [list $FSUB " "] $template] + } else { + set resultlines [list] + set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] + set contentindex 0 + switch -- $opt_textalign { + left {set pad right} + right {set pad left} + default {set pad $opt_textalign} + } + + #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] ""] ;# should not affect actual_contentwidth + } + + #set cwidth [textblock::width $contents] + set cwidth $actual_contentwidth + if {$opt_pad} { + 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} { + set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] + } + #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 { + if {$cwidth > $cache_patternwidth} { + set contents [overtype::renderspace -width $cache_patternwidth "" $contents] + } + set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line + } + + set tlines [split $template \n] + + #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. + #after textblock::join the reset will be a separate code ie should be exactly ESC[0m + set R [a] + set rlen [tcl::string::length $R] + set clines [split $contentblock \n] + + foreach tline $tlines { + if {[tcl::string::first $FSUB $tline] >= 0} { + set content_line [lindex $clines $contentindex] + if {[tcl::string::first $R [string range $content_line 0 10]] == 0} { + set content_line [tcl::string::range $content_line $rlen end] + } + #make sure to replay opt_ansibase to the right of the replacement + lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline] + incr contentindex + } else { + lappend resultlines $tline + } + } + set fs [::join $resultlines \n] + } + + + if {$is_cached} { + return $fs + } else { + if {$buildcache} { + tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] + } + return $fs + } + } + punk::args::define { + @id -id ::textblock::gcross + -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block + Only cross sizes that divide the size of the overall block will be used. + e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. + Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) + If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. + " + @values -min 0 -max 1 + size -default 1 -type integer + } + proc gcross {args} { + set argd [punk::args::get_by_id ::textblock::gcross $args] + set size [dict get $argd values size] + set opts [dict get $argd opts] + + if {$size == 0} { + return "" + } + + set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] + + #set fit_size [punk::lib::greatestOddFactor $size] + set fit_size $size + if {$opt_max_cross_size == 0} { + set max_cross_size $fit_size + } else { + #todo - only allow divisors + #set testsize [expr {min($fit_size,$opt_max_cross_size)}] + + set factors [punk::lib::factors $size] + #pick odd size in list that is smaller or equal to test_size + set max_cross_size [lindex $factors end] + set last_ok [lindex $factors 0] + for {set i 0} {$i < [llength $factors]} {incr i} { + set s [lindex $factors $i] + if {$s > $opt_max_cross_size} { + break + } + set last_ok $s + } + set max_cross_size $last_ok + } + set crosscount [expr {$size / $max_cross_size}] + + package require punk::char + set x [punk::char::charshort boxd_ldc] + set bs [punk::char::charshort boxd_ldgullr] + set fs [punk::char::charshort boxd_ldgurll] + + set onecross "" + set crossrows [list] + set armsize [expr {int(floor($max_cross_size /2))}] + set row [lrepeat $max_cross_size " "] + #toparm + for {set i 0} {$i < $armsize} {incr i} { + set r $row + lset r $i $bs + lset r end-$i $fs + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + + if {$max_cross_size % 2} { + #only put centre cross in for odd sized crosses + set r $row + lset r $armsize $x + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + + for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} { + set r $row + lset r $i $fs + lset r end-$i $bs + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + #set onecross [tcl::string::trimright $onecross \n] + set onecross [::join $crossrows \n] + + #fastest to do row first then columns - because textblock::join must do line by line + + if {$crosscount > 1} { + set row [textblock::join -- {*}[lrepeat $crosscount $onecross]] + set rows [lrepeat $crosscount $row] + set out [::join $rows \n] + } else { + set out $onecross + } + + return $out + } + + #Test we can join two coloured blocks + proc test_colour {} { + set b1 [a red]1\n2\n3[a] + set b2 [a green]a\nb\nc[a] + set result [textblock::join -- $b1 $b2] + puts $result + #return [list $b1 $b2 $result] + return [ansistring VIEW $result] + } + tcl::namespace::import ::punk::ansi::ansistrip +} + + +tcl::namespace::eval ::textblock::piper { + tcl::namespace::export * + proc join {rhs pipelinedata} { + tailcall ::textblock::join -- $pipelinedata $rhs + } +} +interp alias {} piper_blockjoin {} ::textblock::piper::join + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide textblock [tcl::namespace::eval textblock { + variable version + set version 0.1.3 +}] +return + +#*** !doctools +#[manpage_end] +