From cbc49f02d760c155a089a79fc8ac3bdc645a6ff7 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Sat, 22 Jun 2024 11:21:17 +1000 Subject: [PATCH] shellfilter better ansiwrap, textblock::table performance --- src/modules/argparsingtest-999999.0a1.0.tm | 49 ++ src/modules/natsort-0.1.1.6.tm | 51 +- src/modules/punk/ansi-999999.0a1.0.tm | 52 +- src/modules/punk/args-999999.0a1.0.tm | 5 + src/modules/punk/basictelnet-999999.0a1.0.tm | 38 +- src/modules/punk/config-0.1.tm | 7 + src/modules/punk/experiment-999999.0a1.0.tm | 34 ++ src/modules/punk/mix/base-0.1.tm | 5 +- src/modules/punk/repl-0.1.tm | 5 +- src/modules/punkcheck-0.1.0.tm | 37 +- src/modules/shellfilter-0.1.9.tm | 138 +++++- src/modules/shellrun-0.1.1.tm | 2 +- src/modules/textblock-999999.0a1.0.tm | 475 ++++++++++++++----- 13 files changed, 710 insertions(+), 188 deletions(-) diff --git a/src/modules/argparsingtest-999999.0a1.0.tm b/src/modules/argparsingtest-999999.0a1.0.tm index b2e41c5..c76bb4e 100644 --- a/src/modules/argparsingtest-999999.0a1.0.tm +++ b/src/modules/argparsingtest-999999.0a1.0.tm @@ -109,6 +109,26 @@ namespace eval argparsingtest { #[para] Core API functions for argparsingtest #[list_begin definitions] + proc test1_ni {args} { + set defaults [dict create\ + -return string\ + -frametype \uFFEF\ + -show_edge \uFFEF\ + -show_seps \uFFEF\ + -x ""\ + -y b\ + -z c\ + -1 1\ + -2 2\ + -3 3\ + ] + foreach {k v} $args { + if {$k ni [dict keys $defaults]} { + error "unrecognised option '$k'. Known options [dict keys $defaults]" + } + } + set opts [dict merge $defaults $args] + } proc test1_switchmerge {args} { set defaults [dict create\ -return string\ @@ -158,6 +178,35 @@ namespace eval argparsingtest { } return $opts } + variable switchopts + set switchopts [dict create\ + -return string\ + -frametype \uFFEF\ + -show_edge \uFFEF\ + -show_seps \uFFEF\ + -x ""\ + -y b\ + -z c\ + -1 1\ + -2 2\ + -3 3\ + ] + #slightly slower than just creating the dict within the proc + proc test1_switch_nsvar {args} { + variable switchopts + set opts $switchopts + foreach {k v} $args { + switch -- $k { + -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { + dict set opts $k $v + } + default { + error "unrecognised option '$k'. Known options [dict keys $opts]" + } + } + } + return $opts + } proc test1_switch2 {args} { set opts [dict create\ -return string\ diff --git a/src/modules/natsort-0.1.1.6.tm b/src/modules/natsort-0.1.1.6.tm index ec52c47..1d91b53 100644 --- a/src/modules/natsort-0.1.1.6.tm +++ b/src/modules/natsort-0.1.1.6.tm @@ -856,9 +856,33 @@ namespace eval natsort { return [csv::join $line {*}$opts] } #---------------------------------------- + variable sort_flagspecs + set sort_flagspecs [dict create\ + -caller natsort::sort \ + -return supplied|defaults \ + -defaults [list -collate nocase \ + -winlike 0 \ + -splits "\uFFFF" \ + -topchars {. _} \ + -showsplits 1 \ + -sortmethod ascii \ + -collate "\uFFFF" \ + -inputformat raw \ + -inputformatapply {index data} \ + -inputformatoptions "" \ + -outputformat raw \ + -outputformatoptions "" \ + -cols "\uFFFF" \ + -debug 0 -db "" -stacktrace 0 -splits "\uFFFF" -showsplits 0] \ + -required {all} \ + -extras {none} \ + -commandprocessors {}\ + ] + proc sort {stringlist args} { #puts stdout "natsort::sort args: $args" variable debug + variable sort_flagspecs if {![llength $stringlist]} return if {[llength $stringlist] == 1} { if {"-inputformat" ni $args && "-outputformat" ni $args} { @@ -880,36 +904,13 @@ namespace eval natsort { #-return flagged|defaults doesn't work Review. #flagfilter global processor/allocator not working 2023-08 - set flagspecs [dict create\ - -caller natsort::sort \ - -return supplied|defaults \ - -debugargs $debugargs \ - -defaults [list -collate nocase \ - -winlike 0 \ - -splits "\uFFFF" \ - -topchars {. _} \ - -showsplits 1 \ - -sortmethod ascii \ - -collate "\uFFFF" \ - -inputformat raw \ - -inputformatapply {index data} \ - -inputformatoptions "" \ - -outputformat raw \ - -outputformatoptions "" \ - -cols "\uFFFF" \ - -debug 0 -db "" -stacktrace 0 -splits "\uFFFF" -showsplits 0] \ - -required {all} \ - -extras {none} \ - -commandprocessors {}\ - ] - - set opts [check_flags {*}$flagspecs -values $args] + set opts [check_flags {*}$sort_flagspecs -debugargs $debugargs -values $args] #we can only shortcircuit input list of single element at this point if there aren't non-default -inputformat or -outputformat transformations if {[llength $stringlist] == 1} { set is_basic 1 foreach fname [list -inputformat -outputformat] { - if {[dict get $flagspecs -defaults $fname] ne [dict get $opts $fname]} { + if {[dict get $sort_flagspecs -defaults $fname] ne [dict get $opts $fname]} { set is_basic 0 break } diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 29a4fad..b9aeda7 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -3706,20 +3706,22 @@ tcl::namespace::eval punk::ansi { } sgr_merge_singles $allparts {*}$args } + + variable defaultopts_sgr_merge_singles + set defaultopts_sgr_merge_singles [tcl::dict::create\ + -filter_fg 0\ + -filter_bg 0\ + -filter_reset 0\ + ] + #codes *must* already have been split so that one esc per element in codelist #e.g codelist [a+ Yellow Red underline] [a+ blue] [a+ red] is ok #but codelist "[a+ Yellow Red underline][a+ blue]" [a+ red] is not #(use punk::ansi::ta::split_codes_single) proc sgr_merge_singles {codelist args} { variable codestate_empty - set othercodes [list] - - set opts [tcl::dict::create\ - -filter_fg 0\ - -filter_bg 0\ - -filter_reset 0\ - ] - #safe jumptable test + variable defaultopts_sgr_merge_singles + set opts $defaultopts_sgr_merge_singles foreach {k v} $args { switch -- $k { -filter_fg - -filter_bg - -filter_reset { @@ -3731,6 +3733,7 @@ tcl::namespace::eval punk::ansi { } } + set othercodes [list] set codestate $codestate_empty set codestate_initial $codestate_empty ;#keep a copy for resets. set did_reset 0 @@ -4226,20 +4229,21 @@ tcl::namespace::eval punk::ansi::ta { #detect any ansi escapes #review - only detect 'complete' codes - or just use the opening escapes for performance? - proc detect {text} { + proc detect {text} [string map [list [list $re_ansi_detect]] { #*** !doctools #[call [fun detect] [arg text]] #[para]Return a boolean indicating whether Ansi codes were detected in text #[para] - + regexp $text + }] + #note - micro optimisation of inlining gives us *almost* nothing extra. + #left in place for detect as it's a common call that should be made as fast as possible as it's used to avoid more expensive operations such as split_... + # in general the technique doesn't seem worthwhile for this set of functions. + #the performance is dominated by the complexity of the regexp + proc detect2 {text} { variable re_ansi_detect expr {[regexp $re_ansi_detect $text]} } - proc detect2 {text} { - variable re_ansi_detect2 - expr {[regexp $re_ansi_detect2 $text]} - } - proc detect_open {text} { variable re_ansi_detect_open @@ -4318,7 +4322,10 @@ tcl::namespace::eval punk::ansi::ta { set re "(?:${re_ansi_split})+" return [_perlish_split $re $text] } + #micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds) + #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds) + #- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped. proc split_codes_single {text} { variable re_ansi_split return [_perlish_split $re_ansi_split $text] @@ -5687,7 +5694,7 @@ tcl::namespace::eval punk::ansi::ansistring { - set visuals_opt [tcl::dict::create] + set visuals_opt $debug_visuals if {$opt_esc} { tcl::dict::set visuals_opt ESC [list \x1b \u241b] } @@ -5713,12 +5720,13 @@ tcl::namespace::eval punk::ansi::ansistring { tcl::dict::set visuals_opt SP [list \x20 \u2420] } - set visuals [tcl::dict::merge $visuals_opt $debug_visuals] - set charmap [list] - tcl::dict::for {nm chars} $visuals { - lappend charmap {*}$chars - } - return [tcl::string::map $charmap $string] + #set visuals [tcl::dict::merge $visuals_opt $debug_visuals] + #set charmap [list] + #tcl::dict::for {nm chars} $visuals_opt { + # lappend charmap {*}$chars + #} + #return [tcl::string::map $charmap $string] + return [tcl::string::map [concat {*}[dict values $visuals_opt]] $string] #test of ISO2047 - 7bit - limited set, limited support, somewhat obscure glyphs diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 810eb2f..cccec16 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -266,9 +266,12 @@ tcl::namespace::eval punk::args { #[para] Core API functions for punk::args #[list_begin definitions] + proc Get_argspecs {optionspecs args} { variable argspec_cache variable argspecs + variable initial_optspec_defaults + variable initial_valspec_defaults #ideally we would use a fast hash algorithm to produce a short key with low collision probability. #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. #review - check if there is a built-into-tcl way to do this quickly @@ -279,6 +282,7 @@ tcl::namespace::eval punk::args { } set optionspecs [tcl::string::map [list \r\n \n] $optionspecs] + #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\ @@ -296,6 +300,7 @@ tcl::namespace::eval punk::args { -strip_ansi 0\ -multiple 0\ ] + #checks with no default #-minlen -maxlen -range diff --git a/src/modules/punk/basictelnet-999999.0a1.0.tm b/src/modules/punk/basictelnet-999999.0a1.0.tm index 70a01f0..329ad49 100644 --- a/src/modules/punk/basictelnet-999999.0a1.0.tm +++ b/src/modules/punk/basictelnet-999999.0a1.0.tm @@ -830,26 +830,28 @@ namespace eval punk::basictelnet { puts -nonewline stdout "write:'[ansistring VIEW [encoding convertfrom iso8859-1 $string]]'" #puts -nonewline stdout [encoding convertfrom utf-8 $string] } + variable cmdmap + set cmdmap [dict create\ + ef [list name EOR code 239 meaning "End-of-Record"]\ + f0 [list name SE code 240 meaning "End of subnegotiation parameters"]\ + f1 [list name NOP code 241 meaning "no-op"]\ + f2 [list name "Data Mark" code 242 meaning "The data stream portion of a Synch"]\ + f3 [list name "Break" code 243 meaning "NVT character BRK"]\ + f4 [list name "Interrupt Process" code 244 meaning "The function IP"]\ + f5 [list name "Abort Output" code 245 meaning "The function AO"]\ + f6 [list name "Are You There" code 246 meaning "The function AYT"]\ + f7 [list name "Erase Character" code 247 meaning "The function EC"]\ + f8 [list name "Erase Line" code 248 meaning "The function EL"]\ + f9 [list name "Go Ahead" code 249 meaning "The GA signal"]\ + fa [list name "SB" code 250 meaning "Indicates that what follows is subnegotiation of the indicated option"]\ + fb [list name "WILL" code 251 meaning "Indicates the desire to begin performing, or confimation that you are now performing, the indicated option"]\ + fc [list name "WON'T" code 252 meaning "Indicates the refusal to peform or continue performing, the indicated option"]\ + fd [list name "DO" code 253 meaning "Indicates the request that the other party perform, or confirmation that you are expecting the other party to perform, the indicated option"]\ + fe [list name "DON'T" code 254 meaning "Indicates the demand that the other party stop performaing, or confirmation that you are no longer expecting the other party to perform, the indicated option"]\ + ] proc cmd_info {cmd} { + variable cmdmap #ef - extension to rfc-854 - set cmdmap [dict create\ - ef [list name EOR code 239 meaning "End-of-Record"]\ - f0 [list name SE code 240 meaning "End of subnegotiation parameters"]\ - f1 [list name NOP code 241 meaning "no-op"]\ - f2 [list name "Data Mark" code 242 meaning "The data stream portion of a Synch"]\ - f3 [list name "Break" code 243 meaning "NVT character BRK"]\ - f4 [list name "Interrupt Process" code 244 meaning "The function IP"]\ - f5 [list name "Abort Output" code 245 meaning "The function AO"]\ - f6 [list name "Are You There" code 246 meaning "The function AYT"]\ - f7 [list name "Erase Character" code 247 meaning "The function EC"]\ - f8 [list name "Erase Line" code 248 meaning "The function EL"]\ - f9 [list name "Go Ahead" code 249 meaning "The GA signal"]\ - fa [list name "SB" code 250 meaning "Indicates that what follows is subnegotiation of the indicated option"]\ - fb [list name "WILL" code 251 meaning "Indicates the desire to begin performing, or confimation that you are now performing, the indicated option"]\ - fc [list name "WON'T" code 252 meaning "Indicates the refusal to peform or continue performing, the indicated option"]\ - fd [list name "DO" code 253 meaning "Indicates the request that the other party perform, or confirmation that you are expecting the other party to perform, the indicated option"]\ - fe [list name "DON'T" code 254 meaning "Indicates the demand that the other party stop performaing, or confirmation that you are no longer expecting the other party to perform, the indicated option"]\ - ] if {[dict exists $cmdmap $cmd]} { return [dict get $cmdmap $cmd] } else { diff --git a/src/modules/punk/config-0.1.tm b/src/modules/punk/config-0.1.tm index 44db9a7..5ba7e16 100644 --- a/src/modules/punk/config-0.1.tm +++ b/src/modules/punk/config-0.1.tm @@ -251,6 +251,13 @@ tcl::namespace::eval punk::config { } } + proc configure {args} { + set argd [punk::args::get_dict { + + whichconfig -type string -choices {startup running} + }] + } + proc show {whichconfig} { #todo - tables for console variable startup diff --git a/src/modules/punk/experiment-999999.0a1.0.tm b/src/modules/punk/experiment-999999.0a1.0.tm index 70492f9..3abec5a 100644 --- a/src/modules/punk/experiment-999999.0a1.0.tm +++ b/src/modules/punk/experiment-999999.0a1.0.tm @@ -435,6 +435,40 @@ namespace eval punk::experiment { return $result } + #timings indistinguishable + proc map_var {n str} { + set map [list a AA b B c CC d D e EE f F g GG h H i II j J k KK l L m MM] + set out [list] + for {set i 0} {$i < $n} {incr i} { + lappend out [string map $map $str] + } + return $out + } + proc map_inline {n str} { + set out [list] + for {set i 0} {$i < $n} {incr i} { + lappend out [string map [list a AA b B c CC d D e EE f F g GG h H i II j J k KK l L m MM] $str] + } + return $out + } + + variable b1 + set b1 [textblock::block 12 12 .] + variable b2 + set b2 [textblock::block 12 12 x] + variable b3 + set b3 [textblock::join [textblock::block 6 12 @] $b2] + proc render1 {} { + variable b1 + variable b2 + overtype::renderspace -overflow 1 -startcolumn 7 $b1 $b2 + } + proc render2 {} { + variable b1 + variable b3 + overtype::renderspace -overflow 1 -transparent @ $b1 $b3 + } + oo::class create c1 { method test1 args [info body ::punk::experiment::test1] method test2 args [info body ::punk::experiment::test2] diff --git a/src/modules/punk/mix/base-0.1.tm b/src/modules/punk/mix/base-0.1.tm index a979557..6eec4d8 100644 --- a/src/modules/punk/mix/base-0.1.tm +++ b/src/modules/punk/mix/base-0.1.tm @@ -420,8 +420,11 @@ namespace eval punk::mix::base { } #not just used by cksum_path. used by caller (e.g fill_relativecksums_from_base_and_relativepathdict via cksum_filter_opts) to determine what opt names passed through + variable cksum_default_opts + set cksum_default_opts [dict create -cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1] proc cksum_default_opts {} { - return [dict create -cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1] + variable cksum_default_opts + return $cksum_default_opts } #crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?) diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index 75193c8..b7ffcb7 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -2582,11 +2582,14 @@ namespace eval repl { namespace export {[a-z]*} namespace ensemble create namespace ensemble configure [namespace current] -unknown ::repl::interphelpers::repl_ensemble_unknown + variable replinfo + set replinfo [dict create thread %replthread% interp %replthread_interp%] proc thread {} { return %replthread% } proc info {} { - return [dict create thread %replthread% interp %replthread_interp%] + variable replinfo + return $replinfo } proc eval {script} { thread::send %replthread% $script diff --git a/src/modules/punkcheck-0.1.0.tm b/src/modules/punkcheck-0.1.0.tm index ccef062..56d42b2 100644 --- a/src/modules/punkcheck-0.1.0.tm +++ b/src/modules/punkcheck-0.1.0.tm @@ -116,16 +116,21 @@ namespace eval punkcheck { } method as_record {} { - - set fields [list\ + #set fields [list\ + # -targets $o_targets\ + # -keep_installrecords $o_keep_installrecords\ + # -keep_skipped $o_keep_skipped\ + # -keep_inprogress $o_keep_inprogress\ + # body $o_records\ + #] + + dict create \ + tag FILEINFO\ -targets $o_targets\ -keep_installrecords $o_keep_installrecords\ -keep_skipped $o_keep_skipped\ -keep_inprogress $o_keep_inprogress\ - body $o_records\ - ] - - set record [dict create tag FILEINFO {*}$fields] + body $o_records } #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS @@ -199,7 +204,21 @@ namespace eval punkcheck { } else { set tsiso_end "" } - set fields [list\ + #set fields [list\ + # -tsiso_begin $tsiso_begin\ + # -ts_begin $o_ts_begin\ + # -tsiso_end $tsiso_end\ + # -ts_end $o_ts_end\ + # -id $o_id\ + # -source $o_rel_sourceroot\ + # -targets $o_rel_targetroot\ + # -types $o_types\ + # -config $o_configdict\ + #] + #set record [dict create tag EVENT {*}$fields] + + dict create \ + tag EVENT\ -tsiso_begin $tsiso_begin\ -ts_begin $o_ts_begin\ -tsiso_end $tsiso_end\ @@ -208,10 +227,8 @@ namespace eval punkcheck { -source $o_rel_sourceroot\ -targets $o_rel_targetroot\ -types $o_types\ - -config $o_configdict\ - ] + -config $o_configdict - set record [dict create tag EVENT {*}$fields] } method get_id {} { return $o_id diff --git a/src/modules/shellfilter-0.1.9.tm b/src/modules/shellfilter-0.1.9.tm index 7bd34f6..ef1f4ed 100644 --- a/src/modules/shellfilter-0.1.9.tm +++ b/src/modules/shellfilter-0.1.9.tm @@ -523,7 +523,7 @@ namespace eval shellfilter::chan { #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) # - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?) #punk::ansi::stripansi converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion - #assumes line-buffering. a more advanced filter required if ansicodes can arrive split accross separate read or write operations! + #assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations! oo::class create ansistrip { variable o_trecord variable o_enc @@ -610,6 +610,8 @@ namespace eval shellfilter::chan { #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it. #It can be useful for test/debugging + #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi + # oo::class create ansiwrap { variable o_trecord variable o_enc @@ -617,6 +619,9 @@ namespace eval shellfilter::chan { variable o_do_colour variable o_do_normal variable o_is_junction + variable o_codestack + variable o_gx_state ;#on/off alt graphics + variable o_buffered constructor {tf} { package require punk::ansi set o_trecord $tf @@ -631,14 +636,115 @@ namespace eval shellfilter::chan { set o_do_colour "" set o_do_normal "" } + set o_codestack [list] + set o_gx_state [expr {off}] + set o_buffered "" ;#hold back data that potentially contains partial ansi codes if {[tcl::dict::exists $tf -junction]} { set o_is_junction [tcl::dict::get $tf -junction] } else { set o_is_junction 0 } } + method Trackcodes {chunk} { + #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" + set buf $o_buffered$chunk + set emit "" + if {[string last \x1b $buf] >= 0} { + #detect will detect ansi SGR and gron groff and other codes + if {[punk::ansi::ta::detect $buf]} { + #split_codes_single regex faster than split_codes - but more resulting parts + set parts [punk::ansi::ta::split_codes_single $buf] + #process all pt/code pairs except for trailing pt + foreach {pt code} [lrange $parts 0 end-1] { + #puts "<==[ansistring VIEW -lf 1 $pt]==>" + if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + append emit $o_do_colour$pt$o_do_normal + #append emit $pt + } else { + append emit $pt + } + + set c1c2 [tcl::string::range $code 0 1] + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3] + switch -- $leadernorm { + 7CSI - 8CSI { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set o_codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #todo - make caching is_sgr method + set dup_posns [lsearch -all -exact $o_codestack $code] + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + } else { + + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set o_gx_state on + } + "B" { + set o_gx_state off + } + } + } + default { + #other ansi codes + } + } + append emit $code + } + + + set trailing_pt [lindex $parts end] + if {[string first \x1b $trailing_pt] >= 0} { + #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" + #may not be plaintext after all + set o_buffered $trailing_pt + #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" + } else { + #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] + if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { + append emit $o_do_colour$trailing_pt$o_do_normal + } else { + append emit $trailing_pt + } + #set o_buffered "" + } + + + } else { + #puts "-->esc but no detect" + #no complete ansi codes - but at least one esc is present + if {[string first \x1b $buf] == [llength $buf]-1} { + #only esc is last char in buf + #puts ">>trailing-esc<<" + set o_buffered \x1b + set emit [string range $buf 0 end-1] + } else { + #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer + append o_buffered $chunk + set emit "" + } + } + } else { + #no esc + #puts stdout [a+ yellow]...[a] + set emit $buf + set o_buffered "" + } + return [dict create emit $emit stacksize [llength $o_codestack]] + } method initialize {transform_handle mode} { - return [list initialize write flush read drain clear finalize] + #clear undesirable in terminal output channels (review) + return [list initialize write flush read drain finalize] } method finalize {transform_handle} { my destroy @@ -646,12 +752,36 @@ namespace eval shellfilter::chan { method watch {transform_handle events} { } method clear {transform_handle} { - return + #In the context of stderr/stdout - we probably don't want clear to run. + #Terminals might call it in the middle of a split ansi code - resulting in broken output. + #Leave clear of it the init call + puts stdout "" + set emit [tcl::encoding::convertto $o_enc $o_buffered] + set o_buffered "" + return $emit } method flush {transform_handle} { - return "" + #puts stdout "" + set emit [tcl::encoding::convertto $o_enc $o_buffered] + set o_buffered "" + return $emit } method write {transform_handle bytes} { + set instring [tcl::encoding::convertfrom $o_enc $bytes] + set streaminfo [my Trackcodes $instring] + set emit [dict get $streaminfo emit] + if {[dict get $streaminfo stacksize] == 0} { + #no ansi on the stack - we can wrap + #review + set outstring "$o_do_colour$emit$o_do_normal" + } else { + set outstring $emit + } + #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" + #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" + return [tcl::encoding::convertto $o_enc $outstring] + } + method Write_naive {transform_handle bytes} { set instring [tcl::encoding::convertfrom $o_enc $bytes] set outstring "$o_do_colour$instring$o_do_normal" #set outstring ">>>$instring" diff --git a/src/modules/shellrun-0.1.1.tm b/src/modules/shellrun-0.1.1.tm index fcf9c20..3cfdcd3 100644 --- a/src/modules/shellrun-0.1.1.tm +++ b/src/modules/shellrun-0.1.1.tm @@ -397,7 +397,7 @@ namespace eval shellrun { lappend chunklist [list stdout $chunk] - + #set c_stderr [punk::config] set chunk "[a+ red bold]stderr[a]" lappend chunklist [list "info" $chunk] diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index ea8795d..b9642fa 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -310,12 +310,12 @@ tcl::namespace::eval textblock { #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_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 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_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] @@ -363,7 +363,7 @@ tcl::namespace::eval textblock { 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 [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 @@ -1395,9 +1395,9 @@ tcl::namespace::eval textblock { 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] + 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" } @@ -1510,14 +1510,16 @@ tcl::namespace::eval textblock { #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::add_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1" + 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::add_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater" + 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::add_row error -maxheight '$opt_maxh' must greater than -minheight '$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 @@ -1564,35 +1566,79 @@ tcl::namespace::eval textblock { } } 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 {hlb blc vll} - set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set joins {down} + 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 {hlb blc vll} - set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set joins {down left} + 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 {hlb blc vll vlr brc} - set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set joins {down left} + 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 {hlb blc vll vlr brc} - set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set joins {down} + 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 ] @@ -1617,11 +1663,10 @@ tcl::namespace::eval textblock { set opt_posn [tcl::dict::get $opts -position] set opt_return [tcl::dict::get $opts -return] - set valid_positions [list left inner right solo] 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: $valid_positions" + 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 { @@ -1638,15 +1683,12 @@ tcl::namespace::eval textblock { set topt_show_header [tcl::dict::get $o_opts_table -show_header] if {$topt_show_header eq ""} { - set allheaders "" + set allheaders 0 set all_cols [tcl::dict::keys $o_columndefs] foreach c $all_cols { - set headerset [tcl::dict::get $o_columndefs $c -headers] - foreach hdr $headerset { - append allheaders $hdr - } + incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] } - if {$allheaders eq ""} { + if {$allheaders == 0} { set do_show_header 0 } else { set do_show_header 1 @@ -1682,36 +1724,6 @@ tcl::namespace::eval textblock { set fname_header $ftype_header } - switch -- $opt_posn { - left { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list down-$fname_body] - set boxlimits_position {hlb blc vll} - set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set joins {down} - } - inner { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list left down-$fname_body] - set boxlimits_position {hlb blc vll} - set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set joins {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 {hlb blc vll vlr brc} - set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set joins {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 {hlb blc vll vlr brc} - set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set joins {down} - } - } 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] @@ -2073,7 +2085,7 @@ tcl::namespace::eval textblock { } } set part_header [join $adjusted_lines \n] - append output $part_header \n + #append output $part_header \n } set r 0 @@ -2116,19 +2128,22 @@ tcl::namespace::eval textblock { } 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 { - set ansibase $body_ansibase$opt_col_ansibase + #cells in column - each new c is in a different row set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - #todo - joinleft,joinright,joindown based on opts in args - #append output [textblock::frame -boxlimits {vll blc hlb} $c]\n - set cell_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 ? @@ -2172,7 +2187,6 @@ tcl::namespace::eval textblock { } } - set ansibase_final $ansibase$row_ansibase$cell_ansibase if {$r == 0} { @@ -2255,12 +2269,20 @@ tcl::namespace::eval textblock { set part_body [tcl::string::range $part_body 0 end-1] } set return_bodyheight [textblock::height $part_body] - append output $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 column $output headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] + return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] } } @@ -2276,8 +2298,8 @@ tcl::namespace::eval textblock { error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" } #assert cidx is integer >=0 - set cdef [tcl::dict::get $o_columndefs $cidx] - set headerlist [tcl::dict::get $cdef -headers] + set cdef [tcl::dict::get $o_columndefs $cidx] + set headerlist [tcl::dict::get $cdef -headers] set num_header_rows [my header_count] set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] @@ -2661,6 +2683,7 @@ tcl::namespace::eval textblock { 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] @@ -2668,7 +2691,6 @@ tcl::namespace::eval textblock { #if {[llength $headers] > 0} { # set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]] #} - set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] if {$spanc eq "1"} { if {$thiscol_widest_header > $colwidth} { set test_width [expr {max($thiscol_widest_header,$colwidth)}] @@ -3205,7 +3227,7 @@ tcl::namespace::eval textblock { set o_column_width_algorithm $opt_algorithm return $o_calculated_column_widths } - method print {args} { + method print2 {args} { variable full_column_cache set full_column_cache [tcl::dict::create] @@ -3259,7 +3281,7 @@ tcl::namespace::eval textblock { set columninfo [my get_column_by_index $c -return dict {*}$flags] tcl::dict::set full_column_cache $c $columninfo } - set nextcol [tcl::dict::get $columninfo column] + 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 ""} { @@ -3320,6 +3342,236 @@ tcl::namespace::eval textblock { 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}] -overflow 1 -experimental test_mode -transparent $TSUB $table $nextcol] + + #set nextcol [textblock::join [textblock::block $padwidth $height $TSUB] $nextcol] + #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $nextcol] + #JMN + + #set nextcol [textblock::join [textblock::block $padwidth $height "\uFFFF"] $nextcol] + #set table [overtype::renderspace -overflow 1 -experimental test_mode -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" + } + } + + #print headers and body using different join mechanisms + # using -startcolumn to do slightly less work + method print {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 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 + lappend body_blocks $nextcol_body + } else { + if {$headerheight > 0} { + set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -overflow 1 -experimental test_mode -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] + } + lappend body_blocks $nextcol_body + #set body_build [textblock::join $body_build[unset body_build] $nextcol_body] + } + incr padwidth $bodywidth + incr colposn + } + if {![llength $body_blocks]} { + set body_build "" + } else { + set body_build [textblock::join {*}$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 {} { set m [my as_matrix] $m format 2string @@ -3490,14 +3742,14 @@ tcl::namespace::eval textblock { tcl::dict::set ecat $e $val } - set cat [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] set ansi [a+ {*}$fc web-black Web-whitesmoke] set val [list ansi $ansi cat other] - foreach e $cat { + 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] @@ -3545,20 +3797,19 @@ tcl::namespace::eval textblock { } proc list_as_table {table_or_colcount datalist args} { - set defaults [tcl::dict::create\ + set opts [tcl::dict::create\ -return string\ -frametype \uFFEF\ -show_edge \uFFEF\ -show_seps \uFFEF\ ] - set opts $defaults foreach {k v} $args { switch -- $k { -return - -show_edge - -show_seps - -frametype { tcl::dict::set opts $k $v } default { - error "unrecognised option '$k'. Known options [tcl::dict::keys $defaults]" + error "unrecognised option '$k'. Known options [tcl::dict::keys $opts]" } } } @@ -3977,8 +4228,14 @@ tcl::namespace::eval textblock { } } + #todo? special case trailing double-reset - insert between resets? set lnum 0 - set parts [punk::ansi::ta::split_codes $block] + if {[punk::ansi::ta::detect $block]} { + set parts [punk::ansi::ta::split_codes $block] + } else { + #single plaintext part + set parts [list $block] + } set line_chunks [list] set line_len 0 foreach {pt ansi} $parts { @@ -4527,7 +4784,7 @@ tcl::namespace::eval textblock { proc frametype {f} { variable frametypes set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] + #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] if {$f ni $frametypes} { set is_custom_dict_ok 1 if {[llength $f] %2 == 0} { @@ -5748,6 +6005,8 @@ tcl::namespace::eval textblock { } return $out } + + #options before content argument - which is allowed to be absent #frame performance (noticeable with complex tables even of modest size) is improved significantly by frame_cache - but is still (2024) a fairly expensive operation. # @@ -5758,6 +6017,27 @@ tcl::namespace::eval textblock { # - but we would need to maintain support for the rendered-string based operations too. proc frame {args} { variable frametypes + + #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\ + ] + set expect_optval 0 set argposn 0 set pmax [expr {[llength $args]-1}] @@ -5791,24 +6071,6 @@ tcl::namespace::eval textblock { } #todo args -justify left|centre|right (center) - 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\ - ] #todo -blockalignbias -textalignbias? #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache foreach {k v} $arglist { @@ -6011,6 +6273,7 @@ tcl::namespace::eval textblock { #set cache_key [concat $arglist $frame_inner_width $frame_inner_height] set hashables [concat $arglist $frame_inner_width $frame_inner_height] package require md5 + #set hash $hashables set hash [md5::md5 -hex $hashables] ;#need fast and unique to content - not cryptographic - review 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