Browse Source

punk::args fixes and more tclcore documentation

master
Julian Noble 3 weeks ago
parent
commit
f13f2f6f61
  1. 8
      src/modules/punk/ansi-999999.0a1.0.tm
  2. 2279
      src/modules/punk/args-999999.0a1.0.tm
  3. 2
      src/modules/punk/args-buildversion.txt
  4. 1211
      src/modules/punk/args/tclcore-999999.0a1.0.tm
  5. 11
      src/modules/punk/cap/handlers/templates-999999.0a1.0.tm
  6. 6
      src/modules/punk/nav/fs-999999.0a1.0.tm
  7. 34
      src/modules/punk/ns-999999.0a1.0.tm
  8. 71
      src/modules/shellrun-0.1.1.tm
  9. 178
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test
  10. 70
      src/modules/textblock-999999.0a1.0.tm

8
src/modules/punk/ansi-999999.0a1.0.tm

@ -3463,7 +3463,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set emit ""
#set parts [punk::ansi::ta::split_codes $text]
set parts [punk::ansi::ta::split_codes_single $text]
foreach {pt codegroup} $parts {
foreach {pt code} $parts {
switch -- [llength $codestack] {
0 {
append emit $base $pt $R
@ -3489,9 +3489,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
}
}
#parts ends on a pt - last codegroup always empty string
if {$codegroup ne ""} {
foreach code [punk::ansi::ta::get_codes_single $codegroup] {
#parts ends on a pt - last code always empty string
if {$code ne ""} {
set c1c2 [tcl::string::range $code 0 1]
set leadernorm [tcl::string::range [tcl::string::map [list\
\x1b\[ 7CSI\
@ -3530,7 +3529,6 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
append emit $code
}
}
}
return [append emit $R]
} else {
return $base$text$R

2279
src/modules/punk/args-999999.0a1.0.tm

File diff suppressed because it is too large Load Diff

2
src/modules/punk/args-buildversion.txt

@ -1,3 +1,3 @@
0.1.8
0.1.9
#First line must be a semantic version number
#all other lines are ignored.

1211
src/modules/punk/args/tclcore-999999.0a1.0.tm

File diff suppressed because it is too large Load Diff

11
src/modules/punk/cap/handlers/templates-999999.0a1.0.tm

@ -496,10 +496,10 @@ namespace eval punk::cap::handlers::templates {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\
""
@opts -anyopts 1
@opts -any true
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
@values -maxvalues -1 -unnamed true
}]
method get_itemdict_projectlayouts {args} {
@ -552,6 +552,13 @@ namespace eval punk::cap::handlers::templates {
}
return $layoutdict
}
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayoutrefs"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayoutrefs " -help\
""
@opts -arbitrary true
@values -maxvalues -1 -unnamed 1
}]
method get_itemdict_projectlayoutrefs {args} {
set config {
-templatefolder_subdir "layout_refs"\

6
src/modules/punk/nav/fs-999999.0a1.0.tm

@ -641,7 +641,7 @@ tcl::namespace::eval punk::nav::fs {
@id -id ::punk::nav::fs::dirfiles
-stripbase -default 1 -type boolean
-formatsizes -default 1 -type boolean -help "Format file size numbers for clarity"
@values -min 0 -max -1
@values -min 0 -max -1 -unnamed true
}
proc dirfiles {args} {
set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args]
@ -735,7 +735,7 @@ tcl::namespace::eval punk::nav::fs {
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
@values -min 0 -max -1 -type string -unnamed true
}
proc dirfiles_dict {args} {
set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict]
@ -998,7 +998,7 @@ tcl::namespace::eval punk::nav::fs {
@id -id ::punk::nav::fs::dirfiles_dict_as_lines
-stripbase -default 0 -type boolean
-formatsizes -default 1 -type boolean
@values -min 1 -max -1 -type dict
@values -min 1 -max -1 -type dict -unnamed true
}
#todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing?

34
src/modules/punk/ns-999999.0a1.0.tm

@ -2642,6 +2642,7 @@ tcl::namespace::eval punk::ns {
set querycommand [dict get $values commandpath]
set queryargs [dict get $values subcommand]
#puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'"
#todo - similar to corp? review corp resolution process
#should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented
@ -2879,6 +2880,7 @@ tcl::namespace::eval punk::ns {
set queryargs_untested $queryargs
foreach q $queryargs {
if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} {
#todo: fix
set subitems [dict get $spec FORMS $fid LEADER_NAMES]
if {[llength $subitems]} {
set next [lindex $subitems 0]
@ -2887,6 +2889,9 @@ tcl::namespace::eval punk::ns {
set allchoices [list]
set choices [punk::args::system::Dict_getdef $arginfo -choices {}]
set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}]
#maintenance smell - similar/dup of some punk::args logic - review
#-choiceprefixdenylist ??
set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}]
if {[dict exists $choicegroups ""]} {
dict lappend choicegroups "" {*}$choices
} else {
@ -2895,8 +2900,8 @@ tcl::namespace::eval punk::ns {
dict for {groupname clist} $choicegroups {
lappend allchoices {*}$clist
}
set resolved_q [tcl::prefix::match -error "" $allchoices $q]
if {$resolved_q eq ""} {
set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q]
if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} {
break
}
lappend nextqueryargs $resolved_q
@ -3600,7 +3605,30 @@ tcl::namespace::eval punk::ns {
}
#todo - package up as navns
proc corp {path} {
punk::args::define {
@id -id ::punk::ns::corp
@cmd -name punk::ns::corp -help\
"Show alias or proc information.
'corp' (being the reverse spelling of proc)
will display the Tcl 'proc name args body' statement
for the proc.
Essentially this is a convenient way to display the
proc body including argument info, instead of
separately calling 'info args <proc>' 'info body <proc>'
etc.
The body may display with an additional
comment inserted to display information such as the
namespace origin. Such a comment begins with #corp#."
@opts
@values -min 1 -max -1
commandname -help\
"May be either the fully qualified path for the command,
or a relative name that is resolvable from the current
namespace."
}
proc corp {args} {
set argd [punk::args::parse $args withid ::punk::ns::corp]
set path [dict get $argd values commandname]
#thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp
#Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name)
if {[info exists punk::console::tabwidth]} {

71
src/modules/shellrun-0.1.1.tm

@ -12,6 +12,7 @@ package require punk::ansi
#The user can always use exec for different process error semantics (they don't get exitcode with exec)
namespace eval shellrun {
variable PUNKARGS
variable runout
variable runerr
@ -127,19 +128,35 @@ namespace eval shellrun {
#todo - investigate cause of punk86 run hanging sometimes. An 'after 500' before exit in the called script fixes the issue. punk87 doesn't seem to be affected.
lappend PUNKARGS [list {
@id -id ::shellrun::run
@leaders -min 0 -max 0
@opts
-nonewline -type none
-tcl -type none -default 0
-debug -type none -default 0
--timeout= -type integer
@values -min 1 -max -1
cmdname -type string
cmdarg -type any -multiple 1 -optional 1
}]
proc run {args} {
#set_last_run_display [list]
set splitargs [get_run_opts $args]
set runopts [dict get $splitargs runopts]
set runoptslong [dict get $splitargs runoptslong]
set cmdargs [dict get $splitargs cmdargs]
#set splitargs [get_run_opts $args]
#set runopts [dict get $splitargs runopts]
#set runoptslong [dict get $splitargs runoptslong]
#set cmdargs [dict get $splitargs cmdargs]
set argd [punk::args::parse $args withid ::shellrun::run]
lassign [dict values $argd] leaders opts values received
if {"-nonewline" in $runopts} {
if {[dict exists $received "-nonewline"]} {
set nonewline 1
} else {
set nonewline 0
}
#review nonewline does nothing here..
set idlist_stderr [list]
#we leave stdout without imposed ansi colouring - because the source may be colourised and because ansi-wrapping a stream at whatever boundaries it comes in at isn't a really nice thing to do.
#stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr can be very handy for the run command.
@ -151,15 +168,22 @@ namespace eval shellrun {
#lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}]
set callopts [dict create]
if {"-tcl" in $runopts} {
if {[dict exists $received "-tcl"]} {
dict set callopts -tclscript 1
}
if {"-debug" in $runopts} {
if {[dict exists $received "-debug"]} {
dict set callopts -debug 1
}
if {[dict exists $runoptslong --timeout]} {
dict set callopts -timeout [dict get $runoptslong --timeout] ;#convert to single dash
if {[dict exists $received --timeout]} {
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash
}
set cmdname [dict get $values cmdname]
if {[dict exists $received cmdarg]} {
set cmdarglist [dict get $values cmdarg]
} else {
set cmdarglist {}
}
set cmdargs [concat $cmdname $cmdarglist]
#---------------------------------------------------------------------------------------------
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ]
#---------------------------------------------------------------------------------------------
@ -178,19 +202,31 @@ namespace eval shellrun {
return $exitinfo
}
lappend PUNKARGS [list {
@id -id ::shellrun::runconsole
@leaders -min 0 -max 0
@opts
@values -min 1 -max -1
cmdname -type string
cmdarg -type any -multiple 1 -optional 1
}]
#run in the way tcl unknown does - but without regard to auto_noexec
proc runconsole {args} {
if {![llength $args]} {
error "no commandline specified"
return
set argd [punk::args::parse $args withid ::shellrun::runconsole]
lassign [dict values $argd] leaders opts values received
set cmdname [dict get $values cmdname]
if {[dict exists $received cmdarg]} {
set arglist [dict get $values cmdarg]
} else {
set arglist {}
}
set name [lindex $args 0]
set new [auto_execok $name]
set resolved_cmdname [auto_execok $cmdname]
set repl_runid [punk::get_repl_runid]
#set ::punk::last_run_display [list]
set redir ">&@stdout <@stdin"
uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions]
uplevel 1 [list ::catch [concat exec $redir $resolved_cmdname $arglist] ::tcl::UnknownResult ::tcl::UnknownOptions]
#we can't detect stdout/stderr output from the exec
#for now emit an extra \n on stderr
#todo - there is probably no way around this but to somehow exec in the context of a completely separate console
@ -777,6 +813,11 @@ namespace eval shellrun {
}
}
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::shellrun
}
package provide shellrun [namespace eval shellrun {
variable version

178
src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test

@ -7,17 +7,6 @@ namespace eval ::testspace {
set result ""
}
test parse_withdef_leaders_min_max {Test anonymous leaders with @leaders -min and -max}\
-setup $common -body {
set argd [punk::args::parse {a b c d} withdef {@leaders -min 1 -max 3} ]
lappend result [dict get $argd leaders]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{0 a 1 b 2 c} {3 d}
]
test parse_withdef_leaders_ordering_defaults {Test ordering of leaders when some have defaults}\
-setup $common -body {
@ -69,10 +58,45 @@ namespace eval ::testspace {
x a y b
]
test parse_withdef_values_no_phantom_default {Test no phantom default with intermediate optional argument}\
-setup $common -body {
#y was not received, and has no default, so should not appear in 'values' element
#we don't want to see {x a y {} z b}
set argd [punk::args::parse {a b} withdef @values x {y -optional 1} z]
set vals [dict get $argd values]
set result $vals
}\
-cleanup {
}\
-result [list\
x a z b
]
test parse_withdef_value_multiple1 {Test named value with -multiple true and required trailing value}\
-setup $common -body {
set argd [punk::args::parse {a b c} withdef @values {arg -type string -multiple 1} endval]
lappend result [dict get $argd leaders]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{} {arg {a b} endval c}
]
test parse_withdef_value_multiple2 {Test named value followed by named value with -multiple true and a default}\
-setup $common -body {
set argd [punk::args::parse {a b c} withdef @values A {arg -type string -multiple 1 -default X}]
lappend result [dict get $argd leaders]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{} {A a arg {b c}}
]
test parse_withdef_leader_multiple {Test named leader with -multiple true}\
test parse_withdef_leader_multiple1 {Test named leader with -multiple true and 1 value required}\
-setup $common -body {
#should not error
set argd [punk::args::parse {a b c} withdef {@leaders -min 0} {L -multiple 1} {@values -min 1 -max 1} V]
lappend result [dict get $argd leaders]
lappend result [dict get $argd values]
@ -83,10 +107,21 @@ namespace eval ::testspace {
{L {a b}} {V c}
]
test parse_withdef_leader_min_max {Test unnamed leaders with -min and -max}\
test parse_withdef_leader_min_max1 {Test unnamed leaders with @leaders -min and -max}\
-setup $common -body {
set argd [punk::args::parse {a b c d} withdef {@leaders -min 1 -max 3 -unnamed true} {@values -unnamed true} ]
lappend result [dict get $argd leaders]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{0 a 1 b 2 c} {3 d}
]
test parse_withdef_leader_min_max_with_required_value {Test unnamed leaders with -min and -max followed by required unnamed value}\
-setup $common -body {
#should not error - should allocate d to values
set argd [punk::args::parse {a b c d} withdef {@leaders -min 1 -max 4} {@values -min 1 -max 1}]
set argd [punk::args::parse {a b c d} withdef {@leaders -min 1 -max 4 -unnamed true} {@values -min 1 -max 1 -unnamed true}]
lappend result [dict get $argd leaders]
lappend result [dict get $argd values]
}\
@ -96,10 +131,101 @@ namespace eval ::testspace {
{0 a 1 b 2 c} {3 d}
]
test parse_withdef_leader_stride {Test stride leaders}\
test parse_withdef_value_clause_typedefaults {test clause with optional element and -typedefaults specified}\
-setup $common -body {
set argd [punk::args::parse {1} withdef @values {v -type {int ?int?} -typedefaults {"" 12}}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{v {1 12}}
]
test parse_withdef_value_clause_typedefaults2 {test clause with optional element and -typedefaults specified - entire arg optional -default}\
-setup $common -body {
#-default has deliberate type violations - should still produce result as default is not meant to be subject to validation.
set argd [punk::args::parse {} withdef @values {v -type {int ?int?} -typedefaults {"" 12} -default {x y} -optional 1}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{v {x y}}
]
test parse_withdef_value_clause_defaulted_optional {test clause with optional element and -typedefaults not matching all types}\
-setup $common -body {
#-typedefaults has deliberate type violations - should still produce result as defaulted value is not meant to be subject to validation.
#(uses the ?defaulted-<type>? typelist mechanism)
set argd [punk::args::parse {1} withdef @values {v -type {int ?int?} -typedefaults {"" xxx}}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{v {1 xxx}}
]
test parse_withdef_value_clause_missing_optional {test clause with optional element and no -typedefaults}\
-setup $common -body {
#an optional clause member will be replaced with empty string when missing if there is no -typedefaults
#This empty string needs to be in the result, but not be subject to validation
#(uses the ?ommitted-<type>? typelist mechanism)
set argd [punk::args::parse {1} withdef @values {v -type {int ?int?}}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{v {1 {}}}
]
test parse_withdef_value_clause_arity1 {Test value clause result with optional member}\
-setup $common -body {
#default for missing optional member ?literal(then)? should be empty string
set argd [punk::args::parse {elseif 1 x} withdef {@values} {"elseifclause" -type {literal(elseif) expr ?literal(then)? any}}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{elseifclause {elseif 1 {} x}}
]
test parse_withdef_value_clause_arity2 {Test value clause result with missing optional member in optional clauses at tail}\
-setup $common -body {
set argd [punk::args::parse {1 2 x 1 y} withdef {@values -unnamed true} {arg -multiple 1} {X -type {literal(x) any} -optional 1} {Y -type {literal(y) ?int?} -optional 1}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{arg {1 2} X {x 1} Y {y {}}}
]
test parse_withdef_value_clause_arity3 {Test value clause result with filled optional member in optional clauses at tail}\
-setup $common -body {
set argd [punk::args::parse {1 2 x 1 y 2} withdef {@values -unnamed true} {arg -multiple 1} {X -type {literal(x) any} -optional 1} {Y -type {literal(y) ?int?} -optional 1}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{arg {1 2} X {x 1} Y {y 2}}
]
#todo - test L1 parsed to Lit1 not arg
#punk::args::parse {x y L1} withdef @values (arg -multiple 1) {lit1 -type literal(L1) -optional 1} {lit2 -type literal(L2) -optional 1}
#todo
#see i -form 1 file copy -- x
#fix end-of-opts handling
#see also file copy -force x
#(not handled by punk::args as the command does..)
test parse_withdef_leader_clause {Test leader clause with multiple}\
-setup $common -body {
#see for example ::tcl::dict::create which has a stride of 2
set argd [punk::args::parse {k v e k1 v1 k2 v2} withdef {@leaders} {"key val etc" -multiple 0} {"key val" -multiple 1} {@values -min 0 -max 0}]
#see for example ::tcl::dict::create which has a clause length of 2
set argd [punk::args::parse {k v e k1 v1 k2 v2} withdef {@leaders} {"key val etc" -type {any any any} -multiple 0} {"key val" -type {any any} -multiple 1} {@values -min 0 -max 0}]
lappend result [dict get $argd leaders]
}\
-cleanup {
@ -108,10 +234,10 @@ namespace eval ::testspace {
{{key val etc} {k v e} {key val} {{k1 v1} {k2 v2}}}
]
test parse_withdef_value_stride {Test stride values}\
test parse_withdef_value_clause_multiple {Test value clause with multiple}\
-setup $common -body {
#see for example ::tcl::dict::create which has a stride of 2
set argd [punk::args::parse {k v e k1 v1 k2 v2} withdef {@values} {"key val etc" -multiple 0} {"key val" -multiple 1}]
#see for example ::tcl::dict::create which has a clause length of 2
set argd [punk::args::parse {k v e k1 v1 k2 v2} withdef {@values} {"key val etc" -type {any any any} -multiple 0} {"key val" -type {any any} -multiple 1}]
lappend result [dict get $argd values]
}\
-cleanup {
@ -120,15 +246,15 @@ namespace eval ::testspace {
{{key val etc} {k v e} {key val} {{k1 v1} {k2 v2}}}
]
test parse_withdef_value_stride_error {Test stride values with error due to not enough args for stride}\
test parse_withdef_value_clause_error {Test value clause with error due to not enough args for clause}\
-setup $common -body {
#see for example ::tcl::dict::create which has a stride of 2
if {[catch {punk::args::parse {k v} withdef {@values} {"key val etc" -multiple 0}} emsg eopts]} {
#see for example ::tcl::dict::create which has a clause length of 2
if {[catch {punk::args::parse {k v} withdef {@values} {"key val etc" -type {any any any} -multiple 0}} emsg eopts]} {
set expected [dict get $eopts -errorcode]
if {[lindex $expected 0] eq "PUNKARGS" && [lindex $expected 1] eq "VALIDATION" && [lindex $expected 2 0] eq "stridevaluecount"} {
if {[lindex $expected 0] eq "PUNKARGS" && [lindex $expected 1] eq "VALIDATION" && [lindex $expected 2 0] eq "clausevaluelength"} {
lappend result "RECEIVED_EXPECTED_ERROR"
} else {
lappend result "WRONG_ERROR_RECEIVED - $expected (expected PUNKARGS VALIDATION {stridevaluecount ...} ..."
lappend result "WRONG_ERROR_RECEIVED - $expected (expected PUNKARGS VALIDATION {clausevaluelength ...} ..."
}
} else {
lappend result "MISSING_REQUIRED_ERROR"

70
src/modules/textblock-999999.0a1.0.tm

@ -3928,8 +3928,8 @@ tcl::namespace::eval textblock {
set cols [tcl::dict::keys $o_columndata]
} else {
set cols [list]
foreach colspec $args {
set allcols [tcl::dict::keys $o_columndata]
foreach colspec $args {
if {[tcl::string::first .. $colspec] >=0} {
set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec]
if {[llength $parts] != 3} {
@ -5559,8 +5559,8 @@ tcl::namespace::eval textblock {
"Join blocks of text line by line but don't add padding on each line to enforce uniform width.
Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
"
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
-ansiresets -type any -default auto
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
blocks -type any -multiple 1
}
@ -8519,7 +8519,25 @@ tcl::namespace::eval textblock {
set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth]
set cache_patternwidth $actual_contentwidth
set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n]
set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern]
#review - why do we wrap before overtype call if they have same ansibase?
#underlay is just a block of spaces
#set wrapped_underlay $opt_ansibase$underlay$rstbase
#cache_contentpattern is replacement chars
#set wrapped_cache_contentpattern $opt_ansibase$cache_contentpattern
set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $underlay $cache_contentpattern]
#puts "frame--->ansiwrap -rawansi [ansistring VIEW $opt_ansibase] $cache_inner"
if {$opt_ansibase ne ""} {
if {[punk::ansi::ta::detect $cache_inner]} {
set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner]
} else {
set cache_inner "$opt_ansibase$cache_inner\x1b\[0m"
}
}
#after overtype::block - our actual patternwidth may be less
set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]]
@ -8587,9 +8605,6 @@ tcl::namespace::eval textblock {
if {$actual_contentwidth == 0} {
set fs [tcl::string::map [list $FSUB " "] $template]
} else {
set resultlines [list]
set overwritable [tcl::string::repeat $FSUB $cache_patternwidth]
set contentindex 0
switch -- $opt_textalign {
left {set pad right}
right {set pad left}
@ -8603,6 +8618,17 @@ tcl::namespace::eval textblock {
}
#set cwidth [textblock::width $contents]
#JJJ
set contents_has_ansi [punk::ansi::ta::detect $contents]
if {$opt_ansibase ne ""} {
if {$contents_has_ansi} {
set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents]
} else {
set contents "$opt_ansibase$contents\x1b\[0m"
set contents_has_ansi 1
}
}
set cwidth $actual_contentwidth
if {$opt_pad} {
set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth)
@ -8612,36 +8638,50 @@ tcl::namespace::eval textblock {
set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents]
}
#important to supply end of opts -- to textblock::join - particularly here with arbitrary data
if {$contents_has_ansi} {
set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays
} else {
set contentblock $paddedcontents
}
} else {
if {$cwidth > $cache_patternwidth} {
set contents [overtype::renderspace -width $cache_patternwidth "" $contents]
}
if {$contents_has_ansi} {
set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line
} else {
set contentblock $contents
}
}
set tlines [split $template \n]
#we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too.
#after textblock::join the reset will be a separate code ie should be exactly ESC[0m
set R [a]
set rlen [tcl::string::length $R]
set clines [split $contentblock \n]
set fs ""
#set overwritable [tcl::string::repeat $FSUB $cache_patternwidth]
set pattern_offset [expr {$cache_patternwidth -1}]
set contentindex 0
foreach tline $tlines {
if {[tcl::string::first $FSUB $tline] >= 0} {
set subposn [tcl::string::first $FSUB $tline]
if {$subposn >= 0} {
set content_line [lindex $clines $contentindex]
if {[tcl::string::first $R [string range $content_line 0 10]] == 0} {
set content_line [tcl::string::range $content_line $rlen end]
#review - different forms of reset e.g \x1b\[m ??
if {[string range $content_line 0 3] eq "\x1b\[0m"} {
set content_line [tcl::string::range $content_line 4 end]
}
#make sure to replay opt_ansibase to the right of the replacement
lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline]
append content_line $opt_ansibase
append fs [tcl::string::replace $tline $subposn $subposn+$pattern_offset $content_line] \n
incr contentindex
} else {
lappend resultlines $tline
append fs $tline \n
}
}
if {[string index $fs end] eq "\n"} {
set fs [string range $fs 0 end-1]
}
set fs [::join $resultlines \n]
}

Loading…
Cancel
Save