jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

shellfilter better ansiwrap, textblock::table performance

master
Julian Noble 5 months ago
parent
61541835ca
commit
cbc49f02d7
13 changed files with 710 additions and 188 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 49
      src/modules/argparsingtest-999999.0a1.0.tm
  2. 51
      src/modules/natsort-0.1.1.6.tm
  3. 52
      src/modules/punk/ansi-999999.0a1.0.tm
  4. 5
      src/modules/punk/args-999999.0a1.0.tm
  5. 38
      src/modules/punk/basictelnet-999999.0a1.0.tm
  6. 7
      src/modules/punk/config-0.1.tm
  7. 34
      src/modules/punk/experiment-999999.0a1.0.tm
  8. 5
      src/modules/punk/mix/base-0.1.tm
  9. 5
      src/modules/punk/repl-0.1.tm
  10. 37
      src/modules/punkcheck-0.1.0.tm
  11. 138
      src/modules/shellfilter-0.1.9.tm
  12. 2
      src/modules/shellrun-0.1.1.tm
  13. 475
      src/modules/textblock-999999.0a1.0.tm

49
src/modules/argparsingtest-999999.0a1.0.tm
Unescape View File

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

51
src/modules/natsort-0.1.1.6.tm
Unescape View File

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

52
src/modules/punk/ansi-999999.0a1.0.tm
Unescape View File

@ -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 <re> [list $re_ansi_detect]] {
#*** !doctools
#[call [fun detect] [arg text]]
#[para]Return a boolean indicating whether Ansi codes were detected in text
#[para]
regexp <re> $text
}]
#note - micro optimisation of inlining <re> 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

5
src/modules/punk/args-999999.0a1.0.tm
Unescape View File

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

38
src/modules/punk/basictelnet-999999.0a1.0.tm
Unescape View File

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

7
src/modules/punk/config-0.1.tm
Unescape View File

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

34
src/modules/punk/experiment-999999.0a1.0.tm
Unescape View File

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

5
src/modules/punk/mix/base-0.1.tm
Unescape View File

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

5
src/modules/punk/repl-0.1.tm
Unescape View File

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

37
src/modules/punkcheck-0.1.0.tm
Unescape View File

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

138
src/modules/shellfilter-0.1.9.tm
Unescape View File

@ -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 "<clear>"
set emit [tcl::encoding::convertto $o_enc $o_buffered]
set o_buffered ""
return $emit
}
method flush {transform_handle} {
return ""
#puts stdout "<flush>"
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"

2
src/modules/shellrun-0.1.1.tm
Unescape View File

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

475
src/modules/textblock-999999.0a1.0.tm
Unescape View File

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

Write Preview
Loading…
Cancel
Save