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

more punk::args fixes/tests docs etc

master
Julian Noble 2 months ago
parent
a6bcc6d959
commit
71f26e0465
17 changed files with 3536 additions and 1709 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 298
      src/modules/punk-0.1.tm
  2. 222
      src/modules/punk/ansi-999999.0a1.0.tm
  3. 3032
      src/modules/punk/args-999999.0a1.0.tm
  4. 715
      src/modules/punk/args/tclcore-999999.0a1.0.tm
  5. 4
      src/modules/punk/config-0.1.tm
  6. 174
      src/modules/punk/lib-999999.0a1.0.tm
  7. 108
      src/modules/punk/libunknown-0.1.tm
  8. 45
      src/modules/punk/ns-999999.0a1.0.tm
  9. 53
      src/modules/punk/packagepreference-999999.0a1.0.tm
  10. 3
      src/modules/punk/pipe-999999.0a1.0.tm
  11. 6
      src/modules/punk/repl-999999.0a1.0.tm
  12. 25
      src/modules/shellfilter-0.2.tm
  13. 93
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test
  14. 158
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/choices.test
  15. 76
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/opts.test
  16. 0
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/synopsis.test#..+args+synopsis.test.fauxlink
  17. 233
      src/modules/textblock-999999.0a1.0.tm

298
src/modules/punk-0.1.tm
Unescape View File

@ -561,14 +561,66 @@ namespace eval punk {
@id -id ::punk::grepstr @id -id ::punk::grepstr
@cmd -name punk::grepstr\ @cmd -name punk::grepstr\
-summary\ -summary\
"Grep for regex pattern in supplied (possibly ANSI) string."\ "Grep for regex pattern in plaintext of supplied (possibly ANSI) string."\
-help\ -help\
"" "The grepstr command can find strings in ANSI text even if there are interspersed
ANSI colour codes etc. Even if a word has different coloured/styled letters, the
regex can match the plaintext. (Search is performed on ansistripped text, and then
the matched sections are highlighted and overlayed on the original styled/colourd
input.
If the input string has ANSI movement codes - the resultant text may not be directly
searchable because the parts of a word may be separated by various codes and other
plain text. To search such an input string, the string should first be 'rendered' to
a form where the ANSI only represents SGR styling (and perhaps other non-movement
codes) using something like overtype::renderline or overtype::rendertext."
@leaders -min 0 -max 0 @leaders -min 0 -max 0
@opts @opts
-returnlines -type string -default all -choices {matched all} -returnlines -type string -typesynopsis matched|all -default matched -choicecolumns 1 -choices {matched all} -choicelabels {
-ansistrip -type none "matched"\
-no-linenumbers -type none " Return only lines that matched."
"all"\
" Return all lines.
This has a similar effect to the 'grep' trick of matching on 'pattern|$'
(The $ matches all lines that have an end; ie all lines, but there is no
associated character to which to apply highlighting)
except that when instead using -returnlines all with --line-number, the *
indicator after the linenumber will only be highlighted for lines with matches,
and the following matchcount will indicate zero for non-matching lines."
}
-B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num
-C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\
"Print num lines of leading and trailing context surrounding each match."
-A|--after-context= -parsekey "--after-context" -default 0 -type integer -typesynopsis num
--showbreak= -type string -default "-- %c%\U2260" -help\
"When returning matched lines and there is a break in consecutive output,
display the break with the given string. %c% is a placeholder for the
number of lines skipped.
Use empty-string for no break display.
grepstr --showbreak= needle $haystacklines
The unix grep utility commonly uses -- for this indicator.
grepstr --showbreak=-- needle $haystacklines
Customisation example:
grepstr -n \"--showbreak=(skipped %c% lines)\" needle $haystacklines
"
-ansistrip -type none -help\
"Strip all ansi codes from the input string before processing.
This is not necessary for regex matching purposes, as the matching is always
performed on the ansistripped characters anyway, but by stripping ANSI, the
result only has the ANSI supplied by the -highlight option."
#-n|--line-number as per grep utility, except that we include a * for matches
-n|--line-number -type none -help\
"Each output line is preceded by its relative line number in the file, starting at line 1.
For lines that matched the regex, the line number will be suffixed with a * indicator
with the same highlighting as the matched string(s).
The number of matches in the line immediately follows the *
For lines with no matches the * indicator is present with no highligthing and suffixed
with zeros."
-i|--ignore-case -type none -help\
"Perform case insensitive matching."
-highlight -type list -typesynopsis ansinames -default {green bold Black underline overline} -help\ -highlight -type list -typesynopsis ansinames -default {green bold Black underline overline} -help\
"list of ANSI SGR style codes as supported by and documented in punk::ansi::a?" "list of ANSI SGR style codes as supported by and documented in punk::ansi::a?"
-- -type none -- -type none
@ -585,12 +637,26 @@ namespace eval punk {
if {[dict exists $received -ansistrip]} { if {[dict exists $received -ansistrip]} {
set data [punk::ansi::ansistrip $data] set data [punk::ansi::ansistrip $data]
} }
set highlight [dict get $opts -highlight] set highlight [dict get $opts -highlight]
set returnlines [dict get $opts -returnlines] set returnlines [dict get $opts -returnlines]
if {[dict exists $received -no-linenumbers]} { set context [dict get $opts --context] ;#int
set do_linenums 0 set beforecontext [dict get $opts --before-context]
set beforecontext [expr {max($beforecontext,$context)}]
set aftercontext [dict get $opts --after-context]
set aftercontext [expr {max($aftercontext,$context)}]
set showbreak [dict get $opts --showbreak]
set ignorecase [dict exists $received --ignore-case]
if {$ignorecase} {
set nocase "-nocase"
} else {
set nocase ""
}
if {[dict exists $received --line-number]} {
set do_linenums 1 ;#display lineindex+1
} else { } else {
set do_linenums 1 set do_linenums 0
} }
if {[llength $highlight] == 0} { if {[llength $highlight] == 0} {
@ -604,7 +670,7 @@ namespace eval punk {
set data [string map {\r\n \n} $data] set data [string map {\r\n \n} $data]
if {![punk::ansi::ta::detect $data]} { if {![punk::ansi::ta::detect $data]} {
set lines [split $data \n] set lines [split $data \n]
set matches [lsearch -all -regexp $lines $pattern] set matches [lsearch -all {*}$nocase -regexp $lines $pattern]
set result "" set result ""
if {$returnlines eq "all"} { if {$returnlines eq "all"} {
set returnlines [punk::lib::range 0 [llength $lines]-1] set returnlines [punk::lib::range 0 [llength $lines]-1]
@ -612,48 +678,107 @@ namespace eval punk {
set returnlines $matches set returnlines $matches
} }
set max [lindex $returnlines end] set max [lindex $returnlines end]
if {[string is integer -strict $max]} {
incr max
}
set w1 [string length $max] set w1 [string length $max]
foreach linenum $returnlines { #lineindex is zero based - display of linenums is 1 based
set resultlines [dict create]
foreach lineindex $returnlines {
set ln [lindex $lines $lineindex]
set col1 ""
if {$do_linenums} { if {$do_linenums} {
set col1 "[format %${w1}s $linenum] " set col1 [format %${w1}s [expr {$lineindex+1}]]
}
if {$lineindex in $matches} {
set ln [regsub -all {*}$nocase -- $pattern $ln $H&$R] ;#n
set matchcount [regexp -all {*}$nocase -- $pattern $ln]
if {$do_linenums} {
append col1 $H*$R[format %03s $matchcount]
}
} else { } else {
set col1 "" if {$do_linenums} {
append col1 "*000"
}
}
#---------------------------------------------------------------
set prelines [lrange $lines $lineindex-$beforecontext $lineindex-1]
set s [expr {$lineindex-$beforecontext-1}]
if {$s < -1} {set s -1}
foreach p $prelines {
incr s
#append result "[format %${w1}s [expr {$s+1}]]- " " " $p \n
if {![dict exists $resultlines $s]} {
if {$do_linenums} {
set show "[format %${w1}s [expr {$s+1}]]- $p"
} else {
set show $p
}
dict set resultlines $s $show
}
} }
set ln [lindex $lines $linenum] #---------------------------------------------------------------
if {$linenum in $matches} { if {$do_linenums} {
set ln [regsub -all -- $pattern $ln $H&$R] set show "$col1 $ln"
} else {
set show $ln
}
dict set resultlines $lineindex $show
#---------------------------------------------------------------
set postlines [lrange $lines $lineindex+1 $lineindex+$aftercontext]
set s $lineindex
foreach p $postlines {
incr s
if {![dict exists $resultlines $s]} {
if {$do_linenums} {
set show "[format %${w1}s [expr {$s+1}]]- $p"
} else {
set show $p
}
dict set resultlines $s $show
}
} }
append result $col1 $ln \n #---------------------------------------------------------------
} }
set result [string trimright $result \n]
return $result
} else { } else {
set plain [punk::ansi::ansistrip $data] set plain [punk::ansi::ansistrip $data]
set plainlines [split $plain \n] set plainlines [split $plain \n]
set lines [split $data \n] set lines [split $data \n]
set matches [lsearch -all -regexp $plainlines $pattern] set matches [lsearch -all {*}$nocase -regexp $plainlines $pattern]
if {$returnlines eq "all"} { if {$returnlines eq "all"} {
set returnlines [punk::lib::range 0 [llength $lines]-1] set returnlines [punk::lib::range 0 [llength $lines]-1]
} else { } else {
set returnlines $matches set returnlines $matches
} }
set max [lindex $returnlines end] set max [lindex $returnlines end]
if {[string is integer -strict $max]} {
#if max index is 9 - linenum will be 10, (99->100 etc) - so add one in case we're on such a boundary.
incr max
}
set w1 [string length $max] set w1 [string length $max]
set result "" set result ""
set placeholder \UFFEF ;#review set placeholder \UFFEF ;#review
foreach linenum $returnlines { set resultlines [dict create]
set ln [lindex $lines $linenum] foreach lineindex $returnlines {
set ln [lindex $lines $lineindex]
set col1 ""
if {$do_linenums} { if {$do_linenums} {
set col1 "[format %${w1}s $linenum] " set col1 [format %${w1}s [expr {$lineindex+1}]]
} else { }
set col1 "" if {$lineindex in $matches} {
} set plain_ln [lindex $plainlines $lineindex]
if {$linenum in $matches} { set parts [regexp -all {*}$nocase -indices -inline -- $pattern $plain_ln]
set plain_ln [lindex $plainlines $linenum] set matchcount [llength $parts]
set parts [regexp -all -indices -inline -- $pattern $plain_ln] if {$do_linenums} {
append col1 $H*$R[format %03s $matchcount]
}
if {[llength $parts] == 0} { if {[llength $parts] == 0} {
#shouldn't happen #This probably can't happen (?)
append result $col1 $ln \n #If it does.. it's more likely to be an issue with our line index than with regexp
puts stderr "Unexpected regex mismatch in grepstr - line marked with ??? (shouldn't happen)"
set matchshow "??? $ln"
#dict set resultlines $lineindex $show
} else { } else {
set overlay "" set overlay ""
set i 0 set i 0
@ -667,14 +792,75 @@ namespace eval punk {
append overlay [string repeat $placeholder [string length $tail]] append overlay [string repeat $placeholder [string length $tail]]
#puts "$overlay" #puts "$overlay"
#puts "$ln" #puts "$ln"
append result $col1 [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay] \n set rendered [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay]
if {$do_linenums} {
set matchshow "$col1 $rendered"
} else {
set matchshow $rendered
}
}
#---------------------------------------------------------------
set prelines [lrange $lines $lineindex-$beforecontext $lineindex-1]
set s [expr {$lineindex-$beforecontext-1}]
if {$s < -1} {set s -1}
foreach p $prelines {
incr s
#append result "[format %${w1}s [expr {$s+1}]]- " " " $p \n
if {![dict exists $resultlines $s]} {
if {$do_linenums} {
set show "[format %${w1}s [expr {$s+1}]]- $p"
} else {
set show $p
}
dict set resultlines $s $show
}
}
#---------------------------------------------------------------
dict set resultlines $lineindex $matchshow
#---------------------------------------------------------------
set postlines [lrange $lines $lineindex+1 $lineindex+$aftercontext]
set s $lineindex
foreach p $postlines {
incr s
if {![dict exists $resultlines $s]} {
if {$do_linenums} {
set show "[format %${w1}s [expr {$s+1}]]- $p"
} else {
set show $p
}
dict set resultlines $s $show
}
} }
#---------------------------------------------------------------
} else { } else {
append result $col1 $ln \n if {$do_linenums} {
append col1 "*000"
set show "$col1 $ln"
} else {
set show $ln
}
dict set resultlines $lineindex $show
} }
} }
return $result
} }
set ordered_resultlines [lsort -integer [dict keys $resultlines]]
set result ""
set i -1
foreach r $ordered_resultlines {
incr i
if {$showbreak ne "" && $r > $i} {
set c [expr {$r - $i}]
append result [string map [list %c% $c] $showbreak] \n
}
append result [dict get $resultlines $r] \n
set i $r
}
if {$showbreak ne "" && $i<[llength $lines]-1} {
set c [expr {[llength $lines]-1-$i}]
append result [string map [list %c% $c] $showbreak] \n
}
set result [string trimright $result \n]
return $result
} }
proc stacktrace {} { proc stacktrace {} {
@ -932,20 +1118,6 @@ namespace eval punk {
} }
return $varlist return $varlist
} }
proc splitstrposn {s p} {
if {$p <= 0} {
if {$p == 0} {
list "" $s
} else {
list $s ""
}
} else {
scan $s %${p}s%s
}
}
proc splitstrposn_nonzero {s p} {
scan $s %${p}s%s
}
proc _split_var_key_at_unbracketed_comma {varspecs} { proc _split_var_key_at_unbracketed_comma {varspecs} {
set varlist [list] set varlist [list]
@ -971,18 +1143,8 @@ namespace eval punk {
} }
} else { } else {
if {$c eq ","} { if {$c eq ","} {
#lappend varlist [splitstrposn $token $first_term] lappend varlist [punk::lib::string_splitbefore $token $first_term]
set var $token
set spec ""
if {$first_term > 0} {
lassign [scan $token %${first_term}s%s] var spec
} else {
if {$first_term == 0} {
set var ""
set spec $token
}
}
lappend varlist [list $var $spec]
set token "" set token ""
set token_index -1 ;#reduce by 1 because , not included in next token set token_index -1 ;#reduce by 1 because , not included in next token
set first_term -1 set first_term -1
@ -999,18 +1161,7 @@ namespace eval punk {
incr token_index incr token_index
} }
if {[string length $token]} { if {[string length $token]} {
#lappend varlist [splitstrposn $token $first_term] lappend varlist [punk::lib::string_splitbefore $token $first_term]
set var $token
set spec ""
if {$first_term > 0} {
lassign [scan $token %${first_term}s%s] var spec
} else {
if {$first_term == 0} {
set var ""
set spec $token
}
}
lappend varlist [list $var $spec]
} }
return $varlist return $varlist
} }
@ -1034,6 +1185,7 @@ namespace eval punk {
} else { } else {
if {$c eq ","} { if {$c eq ","} {
if {$first_term > -1} { if {$first_term > -1} {
#lassign [punk::lib::string_splitbefore $token $first_term] v k
set v [string range $token 0 $first_term-1] set v [string range $token 0 $first_term-1]
set k [string range $token $first_term end] ;#key section includes the terminal char set k [string range $token $first_term end] ;#key section includes the terminal char
lappend varlist [list $v $k] lappend varlist [list $v $k]

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

@ -723,7 +723,8 @@ tcl::namespace::eval punk::ansi {
} }
lappend adjusted_row $i lappend adjusted_row $i
} }
append result [textblock::join_basic -- {*}$adjusted_row] \n #append result [textblock::join_basic -- {*}$adjusted_row] \n
append result [textblock::join_basic_raw {*}$adjusted_row] \n
incr rowindex incr rowindex
} }
@ -1981,10 +1982,6 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set blockrow [list] set blockrow [list]
set height 50 ;#number of lines (excluding header) vertically in a blockrow set height 50 ;#number of lines (excluding header) vertically in a blockrow
set columns 5 ;#number of columns in a blockrow set columns 5 ;#number of columns in a blockrow
set i -1
set t ""
set start 0
set colidx -1
variable TK_colour_map ;#use the version without lowercased additions - this gives the display names with casing as shown in Tk colour man page. variable TK_colour_map ;#use the version without lowercased additions - this gives the display names with casing as shown in Tk colour man page.
if {!$do_merge} { if {!$do_merge} {
set map $TK_colour_map set map $TK_colour_map
@ -2031,9 +2028,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set overheight 0 set overheight 0
set t ""
set start 0
set colidx -1
set i -1
foreach cname $keys { foreach cname $keys {
set data [dict get $map $cname]
incr i incr i
set data [dict get $map $cname]
if {$overheight || $i % $height == 0} { if {$overheight || $i % $height == 0} {
set overheight 0 set overheight 0
incr colidx incr colidx
@ -2072,17 +2073,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set fg "rgb-$cdec-contrasting" set fg "rgb-$cdec-contrasting"
$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec]
} }
if {$i == 0 || $i % $height != 0} {
if {$t ne ""} { if {$t ne ""} {
$t configure -frametype {} $t configure -frametype {}
$t configure_column 0 -headers [list "TK colours $start - $i"] $t configure_column 0 -headers [list "TK colours $start - $i"]
$t configure_column 0 -header_colspans [list any] $t configure_column 0 -header_colspans [list any]
$t configure -ansibase_header [a+ {*}$fc web-black Web-white] $t configure -ansibase_header [a+ {*}$fc web-black Web-white]
lappend blockrow [$t print] " " lappend blockrow [$t print] " "
lappend blocklist $blockrow lappend blocklist $blockrow
$t destroy $t destroy
}
} }
set result "" set result ""
foreach blockrow $blocklist { foreach blockrow $blocklist {
append result [textblock::join -- {*}$blockrow] \n append result [textblock::join -- {*}$blockrow] \n
@ -2569,16 +2570,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
$t add_row [list $i $descr $s [ansistring VIEW $s]] $t add_row [list $i $descr $s [ansistring VIEW $s]]
} }
x11 - X11 { x11 - X11 {
set tail [tcl::string::tolower [tcl::string::range $i 4 end]] set cname [tcl::string::tolower [tcl::string::range $i 4 end]]
set cont [string range $tail end-11 end] set cont [string range $cname end-11 end]
switch -- $cont { switch -exact -- $cont {-contrasting - -contrastive {set cname [string range $tail end-12]}}
-contrasting - -contrastive {
set cname [string range $tail 0 end-12]
}
default {
set cname $tail
}
}
if {[tcl::dict::exists $X11_colour_map $cname]} { if {[tcl::dict::exists $X11_colour_map $cname]} {
set dec [tcl::dict::get $X11_colour_map $cname] set dec [tcl::dict::get $X11_colour_map $cname]
set hex [colour_dec2hex $dec] set hex [colour_dec2hex $dec]
@ -2854,18 +2849,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#variable WEB_colour_map #variable WEB_colour_map
#upvar ::punk::ansi::WEB_colour_map WEB_colour_map #upvar ::punk::ansi::WEB_colour_map WEB_colour_map
#foreground web colour #foreground web colour
set tail [tcl::string::tolower [tcl::string::range $i 4 end]] set cname [tcl::string::tolower [tcl::string::range $i 4 end]]
#-contrasting #-contrasting
#-contrastive #-contrastive
set cont [string range $tail end-11 end] set cont [string range $cname end-11 end]
switch -- $cont { switch -- $cont { -contrasting - -contrastive {set cname [string range $cname 0 end-12]} }
-contrasting - -contrastive {
set cname [string range $tail 0 end-12]
}
default {
set cname $tail
}
}
if {[tcl::dict::exists $WEB_colour_map $cname]} { if {[tcl::dict::exists $WEB_colour_map $cname]} {
set rgbdash [tcl::dict::get $WEB_colour_map $cname] set rgbdash [tcl::dict::get $WEB_colour_map $cname]
switch -- $cont { switch -- $cont {
@ -3184,16 +3173,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
tk { tk {
#foreground tk names #foreground tk names
variable TK_colour_map_lookup ;#use the dict with added lowercase versions variable TK_colour_map_lookup ;#use the dict with added lowercase versions
set tail [tcl::string::tolower [tcl::string::range $i 3 end]]
set cont [string range $tail end-11 end] set cname [tcl::string::tolower [tcl::string::range $i 3 end]]
switch -- $cont { lassign [punk::lib::string_splitbefore $cname end-11] c cont
-contrasting - -contrastive { switch -exact -- $cont { -contrasting - -contrastive {set cname $c} }
set cname [string range $tail 0 end-12]
}
default {
set cname $tail
}
}
if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { if {[tcl::dict::exists $TK_colour_map_lookup $cname]} {
set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname] set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname]
@ -3216,17 +3199,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
Tk - TK { Tk - TK {
#background X11 names #background X11 names
variable TK_colour_map_lookup ;#with lc versions variable TK_colour_map_lookup ;#with lc versions
set tail [tcl::string::tolower [tcl::string::range $i 3 end]]
set cont [string range $tail end-11 end] set cname [tcl::string::tolower [tcl::string::range $i 3 end]]
switch -- $cont { lassign [punk::lib::string_splitbefore $cname end-11] c cont
-contrasting - -contrastive { switch -- $cont { -contrasting - -contrastive {set cname $c} }
set cname [string range $tail 0 end-12]
}
default {
set cname $tail
}
}
#set cname [tcl::string::tolower [tcl::string::range $i 3 end]]
if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { if {[tcl::dict::exists $TK_colour_map_lookup $cname]} {
set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname] set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname]
switch -- $cont { switch -- $cont {
@ -3251,7 +3228,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} elseif {[tcl::string::first : $i] > 0} { } elseif {[tcl::string::first : $i] > 0} {
lappend e $i lappend e $i
} else { } else {
puts stderr "punk::ansi::a+ ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" puts stderr "punk::ansi::a+ ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- tk- term- rgb# rgb-"
} }
} }
} }
@ -3751,8 +3728,6 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
-rawansi -type ansi -default "" -rawansi -type ansi -default ""
-resetcodes -type list -default {reset} -resetcodes -type list -default {reset}
-rawresets -type ansi -default "" -rawresets -type ansi -default ""
-fullcodemerge -type boolean -default 0 -help\
"experimental"
-overridecodes -type list -default {} -overridecodes -type list -default {}
-rawoverrides -type ansi -default "" -rawoverrides -type ansi -default ""
@values -min 1 -max 1 @values -min 1 -max 1
@ -3767,13 +3742,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} }
#we know there are no valid codes that start with - #we know there are no valid codes that start with -
if {[lsearch [lrange $args 0 end-1] -*] == -1} { if {[lsearch [lrange $args 0 end-1] -*] == -1} {
#no opts #no opts - skip args parser
set text [lindex $args end] #maint: keep defaults in sync with definition above
set codelists [lrange $args 0 end-1] set codelists $args
set R [a] ;#plain ansi reset set text [lpop codelists]
set R [a] ;#plain ansi reset (equiv of default "reset")
set rawansi "" set rawansi ""
set rawresets "" set rawresets ""
set fullmerge 0
set overrides "" set overrides ""
set rawoverrides "" set rawoverrides ""
} else { } else {
@ -3784,7 +3759,6 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set rawansi [dict get $opts -rawansi] set rawansi [dict get $opts -rawansi]
set R [a+ {*}[dict get $opts -resetcodes]] set R [a+ {*}[dict get $opts -resetcodes]]
set rawresets [dict get $opts -rawresets] set rawresets [dict get $opts -rawresets]
set fullmerge [dict get $opts -fullcodemerge]
set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]] set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]]
set rawoverrides [punk::ansi::ta::get_codes_single [dict get $opts -rawoverrides]] set rawoverrides [punk::ansi::ta::get_codes_single [dict get $opts -rawoverrides]]
} }
@ -3793,22 +3767,18 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#there can be SGR unmergeables (due to enhanced underlines) as well as non SGR codes #there can be SGR unmergeables (due to enhanced underlines) as well as non SGR codes
set codes [concat {*}$codelists] ;#flatten set codes [concat {*}$codelists] ;#flatten
set base [a+ {*}$codes] set base [a+ {*}$codes]
set baselist [punk::ansi::ta::get_codes_single $base]
if {$rawansi ne ""} { if {$rawansi ne ""} {
set rawcodes [punk::ansi::ta::get_codes_single $rawansi] ;#caller may have supplied as [a+ xxx][a+ yyy] set rawcodes [punk::ansi::ta::get_codes_single $rawansi] ;#caller may have supplied as [a+ xxx][a+ yyy]
if {$fullmerge} { set base [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$rawcodes]]
set base [punk::ansi::codetype::sgr_merge [list $base {*}$rawcodes]] set baselist [punk::ansi::ta::get_codes_single $base]
} else {
set base [punk::ansi::codetype::sgr_merge_singles [list $base {*}$rawcodes]]
}
} }
if {$rawresets ne ""} { if {$rawresets ne ""} {
set rawresetcodes [punk::ansi::ta::get_codes_single $rawresets] set rawresetcodes [punk::ansi::ta::get_codes_single $rawresets]
if {$fullmerge} { set Rcodes [punk::ansi::ta::get_codes_single $R]
set R [punk::ansi::codetype::sgr_merge [list $R {*}$rawresetcodes]] set R [punk::ansi::codetype::sgr_merge_singles [list {*}$Rcodes {*}$rawresetcodes]]
} else {
set R [punk::ansi::codetype::sgr_merge_singles [list $R {*}$rawresetcodes]]
}
} }
if {$rawoverrides ne ""} { if {$rawoverrides ne ""} {
set rawoverridecodes [punk::ansi::ta::get_codes_single $rawoverrides] set rawoverridecodes [punk::ansi::ta::get_codes_single $rawoverrides]
set overrides [list {*}$overrides {*}$rawoverridecodes] set overrides [list {*}$overrides {*}$rawoverridecodes]
@ -3830,20 +3800,105 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set codestack [list] set codestack [list]
} else { } else {
#append emit [lindex $o_codestack 0]$pt #append emit [lindex $o_codestack 0]$pt
if {$fullmerge} { append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$codestack {*}$overrides]] $pt $R
append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R }
}
default {
append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$codestack {*}$overrides]] $pt $R
}
}
#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\
\x9b 8CSI\
\x1b\( 7GFX\
] $c1c2] 0 3]
switch -- $leadernorm {
7CSI - 8CSI {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set codestack [list "\x1b\[m"]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
#todo - make caching is_sgr method
set dup_posns [lsearch -all -exact $codestack $code]
set codestack [lremove $codestack {*}$dup_posns]
lappend codestack $code
} else { } else {
append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R
} }
} }
7GFX {
switch -- [tcl::string::index $code 2] {
"0" {
set o_gx_state on
}
"B" {
set o_gx_state off
}
}
}
default {
#other ansi codes
}
} }
default { append emit $code
if {$fullmerge} { }
append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R }
return [append emit $R]
} else {
return $base$text$R
}
}
proc ansiwrap_raw {rawansi rawresets rawoverrides text} {
set codelists ""
set R ""
set overrides ""
#note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence.
#there can be SGR unmergeables (due to enhanced underlines) as well as non SGR codes
set codes [concat {*}$codelists] ;#flatten
set base [a+ {*}$codes]
set baselist [punk::ansi::ta::get_codes_single $base]
if {$rawansi ne ""} {
set rawcodes [punk::ansi::ta::get_codes_single $rawansi] ;#caller may have supplied as [a+ xxx][a+ yyy]
set base [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$rawcodes]]
set baselist [punk::ansi::ta::get_codes_single $base]
}
if {$rawresets ne ""} {
set rawresetcodes [punk::ansi::ta::get_codes_single $rawresets]
set Rcodes [punk::ansi::ta::get_codes_single $R]
set R [punk::ansi::codetype::sgr_merge_singles [list {*}$Rcodes {*}$rawresetcodes]]
}
if {$rawoverrides ne ""} {
set rawoverridecodes [punk::ansi::ta::get_codes_single $rawoverrides]
set overrides [list {*}$overrides {*}$rawoverridecodes]
}
set codestack [list]
if {[punk::ansi::ta::detect $text]} {
set emit ""
#set parts [punk::ansi::ta::split_codes $text]
set parts [punk::ansi::ta::split_codes_single $text]
foreach {pt code} $parts {
switch -- [llength $codestack] {
0 {
append emit $base $pt $R
}
1 {
if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} {
append emit $base $pt $R
set codestack [list]
} else { } else {
append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R #append emit [lindex $o_codestack 0]$pt
append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$codestack {*}$overrides]] $pt $R
} }
} }
default {
append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$codestack {*}$overrides]] $pt $R
}
} }
#parts ends on a pt - last code always empty string #parts ends on a pt - last code always empty string
if {$code ne ""} { if {$code ne ""} {
@ -3889,6 +3944,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} else { } else {
return $base$text$R return $base$text$R
} }
} }
proc ansiwrap_naive {codes text} { proc ansiwrap_naive {codes text} {
return [a_ {*}$codes]$text[a] return [a_ {*}$codes]$text[a]

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

File diff suppressed because it is too large Load Diff

715
src/modules/punk/args/tclcore-999999.0a1.0.tm
View File

File diff suppressed because it is too large Load Diff

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

@ -449,7 +449,7 @@ tcl::namespace::eval punk::config {
Accepts globs eg XDG*" Accepts globs eg XDG*"
@leaders -min 1 -max 1 @leaders -min 1 -max 1
#todo - load more whichconfig choices? #todo - load more whichconfig choices?
whichconfig -type string -choices {config startup-configuration running-configuration} whichconfig -type any -choices {config startup-configuration running-configuration}
@values -min 0 -max -1 @values -min 0 -max -1
globkey -type string -default * -optional 1 -multiple 1 globkey -type string -default * -optional 1 -multiple 1
}] }]
@ -495,7 +495,7 @@ tcl::namespace::eval punk::config {
@cmd -name punk::config::configure -help\ @cmd -name punk::config::configure -help\
"Get/set configuration values from a config" "Get/set configuration values from a config"
@leaders -min 1 -max 1 @leaders -min 1 -max 1
whichconfig -type string -choices {defaults startup-configuration running-configuration} whichconfig -type any -choices {defaults startup-configuration running-configuration}
@values -min 0 -max 2 @values -min 0 -max 2
key -type string -optional 1 key -type string -optional 1
newvalue -optional 1 newvalue -optional 1

174
src/modules/punk/lib-999999.0a1.0.tm
Unescape View File

@ -347,7 +347,7 @@ tcl::namespace::eval punk::lib::compat {
proc ledit {lvar first last args} { proc ledit {lvar first last args} {
upvar $lvar l upvar $lvar l
#use lindex_resolve to support for example: ledit lst end+1 end+1 h i #use lindex_resolve to support for example: ledit lst end+1 end+1 h i
set fidx [punk::lib::lindex_resolve $l $first] set fidx [punk::lib::lindex_resolve [llength $l] $first]
switch -exact -- $fidx { switch -exact -- $fidx {
-3 { -3 {
#index below lower bound #index below lower bound
@ -363,7 +363,7 @@ tcl::namespace::eval punk::lib::compat {
set pre [lrange $l 0 $first-1] set pre [lrange $l 0 $first-1]
} }
} }
set lidx [punk::lib::lindex_resolve $l $last] set lidx [punk::lib::lindex_resolve [llength $l] $last]
switch -exact -- $lidx { switch -exact -- $lidx {
-3 { -3 {
#index below lower bound #index below lower bound
@ -741,14 +741,15 @@ namespace eval punk::lib {
proc lswap {lvar a z} { proc lswap {lvar a z} {
upvar $lvar l upvar $lvar l
if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} { set len [llength $l]
if {[lindex_resolve_basic $len $a] < 0 || [lindex_resolve_basic $len $z] < 0} {
#lindex_resolve_basic returns only -1 if out of range #lindex_resolve_basic returns only -1 if out of range
#if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred #if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred
#(e.g using: lswap mylist end-2 end on a two element list) #(e.g using: lswap mylist end-2 end on a two element list)
#on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report
#use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned)
set a_index [lindex_resolve $l $a] set a_index [lindex_resolve $len $a]
set a_msg "" set a_msg ""
switch -- $a_index { switch -- $a_index {
-2 { -2 {
@ -758,7 +759,7 @@ namespace eval punk::lib {
set a_msg "1st supplied index $a is below the lower bound for the list (0)" set a_msg "1st supplied index $a is below the lower bound for the list (0)"
} }
} }
set z_index [lindex_resolve $l $z] set z_index [lindex_resolve $len $z]
set z_msg "" set z_msg ""
switch -- $z_index { switch -- $z_index {
-2 { -2 {
@ -1514,7 +1515,7 @@ namespace eval punk::lib {
if {![regexp $re_idxdashidx $p _match a b]} { if {![regexp $re_idxdashidx $p _match a b]} {
error "unrecognised pattern $p" error "unrecognised pattern $p"
} }
set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high set lower_resolve [punk::lib::lindex_resolve [llength $dval] $a] ;#-2 for too low, -1 for too high
#keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds
if {${lower_resolve} == -2} { if {${lower_resolve} == -2} {
##x ##x
@ -1527,7 +1528,7 @@ namespace eval punk::lib {
} else { } else {
set lower $lower_resolve set lower $lower_resolve
} }
set upper [punk::lib::lindex_resolve $dval $b] set upper [punk::lib::lindex_resolve [llength $dval] $b]
if {$upper == -3} { if {$upper == -3} {
##x ##x
#upper bound is below list range - #upper bound is below list range -
@ -1880,7 +1881,8 @@ namespace eval punk::lib {
if {$last_hidekey} { if {$last_hidekey} {
append result \n append result \n
} }
append result [textblock::join_basic -- $kblock $sblock $vblock] \n #append result [textblock::join_basic -- $kblock $sblock $vblock] \n
append result [textblock::join_basic_raw $kblock $sblock $vblock] \n
} }
set last_hidekey $hidekey set last_hidekey $hidekey
incr kidx incr kidx
@ -2240,18 +2242,19 @@ namespace eval punk::lib {
} }
} }
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bounds on upper vs lower side
#REVIEW: This shouldn't really need the list itself - just the length would suffice
punk::args::define { punk::args::define {
@id -id ::punk::lib::lindex_resolve @id -id ::punk::lib::lindex_resolve
@cmd -name punk::lib::lindex_resolve\ @cmd -name punk::lib::lindex_resolve\
-summary\ -summary\
"Resolve an indexexpression to an integer based on supplied list."\ "Resolve an indexexpression to an integer based on supplied list or string length."\
-help\ -help\
"Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 "Resolve an index which may be of the forms accepted by Tcl list or string commands such as end-2 or 2+2
to the actual integer index for the supplied list, or to a negative value below -1 indicating to the actual integer index for the supplied list/string length, or to a negative value below -1 indicating
whether the index was below or above the range of possible indices for the list. whether the index was below or above the range of possible indices for the length supplied.
Users may define procs which accept a list index and wish to accept the forms understood by Tcl. Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl.
This means the proc may be called with something like $x+2 end-$y etc This means the proc may be called with something like $x+2 end-$y etc
Sometimes the actual integer index is desired. Sometimes the actual integer index is desired.
@ -2261,33 +2264,33 @@ namespace eval punk::lib {
a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0)
b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end)
lindex_resolve never returns -1 - as the similar function lindex_resolve_basic uses this to denote lindex_resolve never returns -1 - as the similar function lindex_resolve_basic uses this to denote
out of range at either end of the list out of range at either end of the list/string.
Otherwise it will return an integer corresponding to the position in the list. Otherwise it will return an integer corresponding to the position in the data.
This is in stark contrast to Tcl list function indices which will return empty strings for out of This is in stark contrast to Tcl list/string function indices which will return empty strings for out of
bounds indices, or in the case of lrange, return results anyway. bounds indices, or in the case of lrange, return results anyway.
Like Tcl list commands - it will produce an error if the form of the index is not acceptable Like Tcl list commands - it will produce an error if the form of the index is not acceptable.
For empty lists, end and end+x indices are considered to be out of bounds on the upper side For empty lists/string (datalength 0), end and end+x indices are considered to be out of bounds on the upper side
- thus returning -2 - thus returning -2
Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command.
We will get something like 10+1 - which can be resolved safely with expr We will get something like 10+1 - which can be resolved safely with expr
" "
@values -min 2 -max 2 @values -min 2 -max 2
list -type list datalength -type integer
index -type indexexpression index -type indexexpression
} }
proc lindex_resolve {list index} { proc lindex_resolve {len index} {
#*** !doctools #*** !doctools
#[call [fun lindex_resolve] [arg list] [arg index]] #[call [fun lindex_resolve] [arg len] [arg index]]
#[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list #[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list/string length
#[para]Users may define procs which accept a list index and wish to accept the forms understood by Tcl. #[para]Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl.
#[para]This means the proc may be called with something like $x+2 end-$y etc #[para]This means the proc may be called with something like $x+2 end-$y etc
#[para]Sometimes the actual integer index is desired. #[para]Sometimes the actual integer index is desired.
#[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks.
#[para]lindex_resolve will parse the index expression and return: #[para]lindex_resolve will parse the index expression and return:
#[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0)
#[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end)
#[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list #[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list/string
#[para]Otherwise it will return an integer corresponding to the position in the list. #[para]Otherwise it will return an integer corresponding to the position in the list.
#[para]This is in stark contrast to Tcl list function indices which will return empty strings for out of bounds indices, or in the case of lrange, return results anyway. #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out of bounds indices, or in the case of lrange, return results anyway.
#[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable
@ -2298,12 +2301,16 @@ namespace eval punk::lib {
# #review # #review
# return ??? # return ???
#} #}
if {![string is integer -strict $len]} {
#<0 ?
error "lindex_resolve len must be an integer"
}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} { if {[string is integer -strict $index]} {
#can match +i -i #can match +i -i
if {$index < 0} { if {$index < 0} {
return -3 return -3
} elseif {$index >= [llength $list]} { } elseif {$index >= $len} {
return -2 return -2
} else { } else {
#integer may still have + sign - normalize with expr #integer may still have + sign - normalize with expr
@ -2320,7 +2327,7 @@ namespace eval punk::lib {
} }
} else { } else {
#index is 'end' #index is 'end'
set index [expr {[llength $list]-1}] set index [expr {$len-1}]
if {$index < 0} { if {$index < 0} {
#special case - 'end' with empty list - treat end like a positive number out of bounds #special case - 'end' with empty list - treat end like a positive number out of bounds
return -2 return -2
@ -2329,7 +2336,7 @@ namespace eval punk::lib {
} }
} }
if {$offset == 0} { if {$offset == 0} {
set index [expr {[llength $list]-1}] set index [expr {$len-1}]
if {$index < 0} { if {$index < 0} {
return -2 ;#special case as above return -2 ;#special case as above
} else { } else {
@ -2337,7 +2344,7 @@ namespace eval punk::lib {
} }
} else { } else {
#by now, if op = + then offset = 0 so we only need to handle the minus case #by now, if op = + then offset = 0 so we only need to handle the minus case
set index [expr {([llength $list]-1) - $offset}] set index [expr {($len-1) - $offset}]
} }
if {$index < 0} { if {$index < 0} {
return -3 return -3
@ -2362,33 +2369,32 @@ namespace eval punk::lib {
} }
if {$index < 0} { if {$index < 0} {
return -3 return -3
} elseif {$index >= [llength $list]} { } elseif {$index >= $len} {
return -2 return -2
} }
return $index return $index
} }
} }
} }
proc lindex_resolve_basic {list index} { proc lindex_resolve_basic {len index} {
#*** !doctools #*** !doctools
#[call [fun lindex_resolve_basic] [arg list] [arg index]] #[call [fun lindex_resolve_basic] [arg len] [arg index]]
#[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2)
#[para] returns -1 for out of range at either end, or a valid integer index #[para] returns -1 for out of range at either end, or a valid integer index
#[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound #[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound
#[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command #[para] This is only likely to be faster than average over lindex_resolve for small lists and for Tcl which has the builtin lseq command
#[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1 #[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1
#[para] For pure integer indices the performance should be equivalent #[para] For pure integer indices the performance should be equivalent
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ if {![string is integer -strict $len]} {
# - which error "lindex_resolve_basic len must be an integer"
#for {set i 0} {$i < [llength $list]} {incr i} { }
# lappend indices $i
#}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} { if {[string is integer -strict $index]} {
#can match +i -i #can match +i -i
#avoid even the lseq overhead when the index is simple #avoid even the lseq overhead when the index is simple
if {$index < 0 || ($index >= [llength $list])} { if {$index < 0 || ($index >= $len)} {
#even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method.
return -1 return -1
} else { } else {
@ -2396,13 +2402,15 @@ namespace eval punk::lib {
return [expr {$index}] return [expr {$index}]
} }
} }
if {[llength $list]} { if {$len > 0} {
set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. #For large len - this is a wasteful allocation if no true lseq available in Tcl version.
#if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) #lseq produces an 'arithseries' object which we can index into without allocating an entire list (REVIEW)
set testlist [punk::lib::range 0 [expr {$len-1}]] ;# uses lseq if available, has fallback.
} else { } else {
set indices [list] set testlist [list]
#we want to call 'lindex' even in this case - to get the appropriate error message
} }
set idx [lindex $indices $index] set idx [lindex $testlist $index]
if {$idx eq ""} { if {$idx eq ""} {
#we have no way to determine if out of bounds is at lower vs upper end #we have no way to determine if out of bounds is at lower vs upper end
return -1 return -1
@ -2421,6 +2429,81 @@ namespace eval punk::lib {
} }
} }
proc string_splitbefore {str index} {
if {![string is integer -strict $index]} {
set index [punk::lib::lindex_resolve [string length $str] $index]
switch -- $index {
-2 {
return [list $str ""]
}
-3 {
return [list "" $str]
}
}
}
return [list [string range $str 0 $index-1] [string range $str $index end]]
#scan %s stops at whitespace - not useful here.
#scan $s %${p}s%s
}
proc string_splitbefore_indices {str args} {
set parts [list $str]
set sizes [list [string length $str]]
set s 0
foreach index $args {
if {![string is integer -strict $index]} {
set index [punk::lib::lindex_resolve [string length $str] $index]
switch -- $index {
-2 {
if {[lindex $sizes end] != 0} {
ledit parts end end [lindex $parts end] {}
ledit sizes end end [lindex $sizes end] 0
}
continue
}
-3 {
if {[lindex $sizes 0] != 0} {
ledit parts 0 0 {} [lindex $parts 0]
ledit sizes 0 0 0 [lindex $sizes 0]
}
continue
}
}
}
if {$index <= 0} {
if {[lindex $sizes 0] != 0} {
ledit parts 0 0 {} [lindex $parts 0]
ledit sizes 0 0 0 [lindex $sizes 0]
}
continue
}
if {$index >= [string length $str]} {
if {[lindex $sizes end] != 0} {
ledit parts end end [lindex $parts end] {}
ledit sizes end end [lindex $sizes end] 0
}
continue
}
set i -1
set a 0
foreach sz $sizes {
incr i
if {$a + $sz > $index} {
set p [lindex $parts $i]
#puts "a:$a index:$index"
if {$a == $index} {
break
}
ledit parts $i $i [string range $p 0 [expr {$index -$a -1}]] [string range $p $index-$a end]
ledit sizes $i $i [expr {$index - $a}] [expr {($a + $sz)-$index}]
break
}
incr a $sz
}
#puts "->parts:$parts"
#puts "->sizes:$sizes"
}
return $parts
}
proc K {x y} {return $x} proc K {x y} {return $x}
#*** !doctools #*** !doctools
@ -3250,8 +3333,7 @@ namespace eval punk::lib {
#Each resulting line should have a reset of some type at start and a pure-reset at end to stop #Each resulting line should have a reset of some type at start and a pure-reset at end to stop
#see if we can find an ST sequence that most terminals will not display for marking sections? #see if we can find an ST sequence that most terminals will not display for marking sections?
if {$opt_ansireplays} { if {$opt_ansireplays} {
#package require punk::ansi <require_punk_ansi> ;#package require punk::ansi
<require_punk_ansi>
if {$opt_ansiresets} { if {$opt_ansiresets} {
set RST "\x1b\[0m" set RST "\x1b\[0m"
} else { } else {

108
src/modules/punk/libunknown-0.1.tm
Unescape View File

@ -129,7 +129,6 @@ tcl::namespace::eval punk::libunknown {
#whie it is not the most common configuration - a package could be provided both as a .tm and by packageIndex.tcl files #whie it is not the most common configuration - a package could be provided both as a .tm and by packageIndex.tcl files
} }
#variable paths #variable paths
upvar ::tcl::tm::paths paths upvar ::tcl::tm::paths paths
#variable pkgpattern #variable pkgpattern
@ -475,6 +474,9 @@ tcl::namespace::eval punk::libunknown {
#question is whether some pkgIndex.tcl files may do a package forget? They probably don't/shouldn't(?) Does that matter here anyway? #question is whether some pkgIndex.tcl files may do a package forget? They probably don't/shouldn't(?) Does that matter here anyway?
set before_dict [dict create] set before_dict [dict create]
#J2
#siblings that have been affected by source scripts - need to retest ifneeded scripts at end for proper ordering.
set refresh_dict [dict create]
#Note that autopath is being processed from the end to the front #Note that autopath is being processed from the end to the front
#ie last lappended first. This means if there are duplicate versions earlier in the list, #ie last lappended first. This means if there are duplicate versions earlier in the list,
@ -487,6 +489,7 @@ tcl::namespace::eval punk::libunknown {
while {[llength $use_path]} { while {[llength $use_path]} {
set dir [lindex $use_path end] set dir [lindex $use_path end]
# Make sure we only scan each directory one time. # Make sure we only scan each directory one time.
if {[info exists tclSeenPath($dir)]} { if {[info exists tclSeenPath($dir)]} {
set use_path [lrange $use_path 0 end-1] set use_path [lrange $use_path 0 end-1]
@ -526,7 +529,6 @@ tcl::namespace::eval punk::libunknown {
#if {$has_zipfs && [string match $zipfsroot* $dir]} { #if {$has_zipfs && [string match $zipfsroot* $dir]} {
#static auto_path dirs #static auto_path dirs
if {!$must_scan} { if {!$must_scan} {
#can avoid scan if added via this path in any epoch
if {[dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} { if {[dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} {
if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} { if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} {
#$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again. #$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again.
@ -551,7 +553,13 @@ tcl::namespace::eval punk::libunknown {
#(or misordered min max e.g package require md5 1-0 i.e a deliberately unsatisfiable version range) #(or misordered min max e.g package require md5 1-0 i.e a deliberately unsatisfiable version range)
set sourced 0 set sourced 0
set just_added [dict create]
set just_changed [dict create]
#set sourced_files [list] #set sourced_files [list]
#J2
#set can_skip_sourcing 0
if {!$can_skip_sourcing} { if {!$can_skip_sourcing} {
#Note - naive comparison of before_pkgs vs after_pkgs isn't quite enough to tell if something was added. It could have added a version. #Note - naive comparison of before_pkgs vs after_pkgs isn't quite enough to tell if something was added. It could have added a version.
#this will stop us rescanning everything properly by doing a 'package require nonexistant' #this will stop us rescanning everything properly by doing a 'package require nonexistant'
@ -577,7 +585,7 @@ tcl::namespace::eval punk::libunknown {
set dir [file dirname $file] set dir [file dirname $file]
if {![info exists procdDirs($dir)]} { if {![info exists procdDirs($dir)]} {
try { try {
#if {[string match //zipfs* $file]} { #if {[string match //zipfs*registry* $file]} {
# puts stderr "----->0 sourcing zipfs file $file" # puts stderr "----->0 sourcing zipfs file $file"
#} #}
incr sourced ;#count as sourced even if source fails; keep before actual source action incr sourced ;#count as sourced even if source fails; keep before actual source action
@ -642,15 +650,16 @@ tcl::namespace::eval punk::libunknown {
} }
set after_pkgs [package names] set after_pkgs [package names]
set just_added [dict create]
#puts "@@@@pkg epochs $pkg_epoch searchpath:$currentsearchpath name:$name before: [llength $before_pkgs] after: [llength $after_pkgs]" #puts "@@@@pkg epochs $pkg_epoch searchpath:$currentsearchpath name:$name before: [llength $before_pkgs] after: [llength $after_pkgs]"
if {[llength $after_pkgs] > [llength $before_pkgs]} { if {[llength $after_pkgs] > [llength $before_pkgs]} {
foreach a $after_pkgs { foreach a $after_pkgs {
foreach v [package versions $a] { foreach v [package versions $a] {
if {![dict exists $before_dict $a $v]} { if {![dict exists $before_dict $a $v]} {
dict set just_added $a $v 1 dict set just_added $a $v 1
set iscript [package ifneeded $a $v]
#J2
#dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a [dict create e $pkg_epoch v $v] #dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a [dict create e $pkg_epoch v $v]
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $v e$pkg_epoch dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $v [dict create e $pkg_epoch scr $iscript]
if {$must_scan} { if {$must_scan} {
dict unset epoch pkg untracked $a dict unset epoch pkg untracked $a
} }
@ -693,18 +702,20 @@ tcl::namespace::eval punk::libunknown {
#The last one found (earlier in auto_path) for a version is the one that supplies the final 'package provide' statement (by overriding it) #The last one found (earlier in auto_path) for a version is the one that supplies the final 'package provide' statement (by overriding it)
# #
dict for {bp bpversionscripts} $before_dict { dict for {bp bpversionscripts} $before_dict {
if {!$must_scan && ![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $bp]} { #if {!$must_scan && ![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $bp]} {
#puts -nonewline . # #puts -nonewline .
continue # continue
} #}
dict for {bv bscript} $bpversionscripts { dict for {bv bscript} $bpversionscripts {
set nowscript [package ifneeded $bp $bv] set nowscript [package ifneeded $bp $bv]
if {$bscript ne $nowscript} { if {$bscript ne $nowscript} {
#ifneeded script has changed. The same version of bp was supplied on this path. #ifneeded script has changed. The same version of bp was supplied on this path.
#As it's processed later - it will be the one in effect. #As it's processed later - it will be the one in effect.
#dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp [dict create e $pkg_epoch v $bv] #dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp [dict create e $pkg_epoch v $bv]
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $bv e$pkg_epoch dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $bv [dict create e $pkg_epoch scr $nowscript]
dict set before_dict $bp $bv $nowscript dict set before_dict $bp $bv $nowscript
dict set just_changed $bp $bv 1
#j2
if {$must_scan} { if {$must_scan} {
dict unset epoch pkg untracked $bp dict unset epoch pkg untracked $bp
} }
@ -806,7 +817,50 @@ tcl::namespace::eval punk::libunknown {
} }
} }
set old_path $auto_path set old_path $auto_path
dict for {pkg versions} $just_changed {
foreach v [dict keys $versions] {
dict set refresh_dict $pkg $v 1
}
}
dict for {pkg versions} $just_added {
foreach v [dict keys $versions] {
dict set refresh_dict $pkg $v 1
}
}
} }
#refresh ifneeded scripts for just_added/just_changed
#review: searchpaths are in auto_path order - earliest has precedence for any particular pkg-version
set e [dict get $epoch pkg current]
set pkgvdone [dict create]
set dict_added [dict get $epoch pkg epochs $e added]
#keys are in reverse order due to tclPkgUnknown processing order
set ordered_searchpaths [lreverse [dict keys $dict_added]];# orderd as in auto_path
dict for {pkg versiond} $refresh_dict {
set versions [dict keys $versiond]
foreach searchpath $ordered_searchpaths {
set addedinfo [dict get $dict_added $searchpath]
set vidx -1
foreach v $versions {
incr vidx
if {[dict exists $addedinfo $pkg $v]} {
ledit versions $vidx $vidx
set iscript [dict get $addedinfo $pkg $v scr]
if {[package ifneeded $pkg $v] ne $iscript} {
#puts "---->refreshing $pkg $v using path:$searchpath"
package ifneeded $pkg $v $iscript
#dict set pkgvdone $pkg $v 1
}
}
}
if {[llength $versions] == 0} {
break
}
}
}
#puts "zipfs_tclPkgUnknown DONE" #puts "zipfs_tclPkgUnknown DONE"
} }
variable last_auto_path variable last_auto_path
@ -1091,7 +1145,7 @@ tcl::namespace::eval punk::libunknown {
set callerposn [lsearch $args -caller] set callerposn [lsearch $args -caller]
if {$callerposn > -1} { if {$callerposn > -1} {
set caller [lindex $args $callerposn+1] set caller [lindex $args $callerposn+1]
puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller\x1b\[m" #puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller\x1b\[m"
#puts stderr "punk::libunknown::init auto_path : $::auto_path" #puts stderr "punk::libunknown::init auto_path : $::auto_path"
#puts stderr "punk::libunknown::init tcl::tm::list: [tcl::tm::list]" #puts stderr "punk::libunknown::init tcl::tm::list: [tcl::tm::list]"
} }
@ -1176,15 +1230,15 @@ tcl::namespace::eval punk::libunknown {
#update the epoch info with where the tm versions came from #update the epoch info with where the tm versions came from
#(not tracking version numbers in epoch - just package to the indexbase) #(not tracking version numbers in epoch - just package to the indexbase)
foreach vdata $versionlist { foreach vdata $versionlist {
lassign $vdata v _t type _index index _indexbase indexbase lassign $vdata v _t type _index index _indexbase indexbase _script iscript
if {$type eq "tm"} { if {$type eq "tm"} {
if {![dict exists $epoch tm epochs 0 added $indexbase]} { if {![dict exists $epoch tm epochs 0 added $indexbase]} {
#dict set epoch tm epochs 0 added $indexbase [dict create $p [dict create e 0 v $v]] #dict set epoch tm epochs 0 added $indexbase [dict create $p [dict create e 0 v $v]]
dict set epoch tm epochs 0 added $indexbase $p $v e0 dict set epoch tm epochs 0 added $indexbase $p $v [dict create e 0 scr $iscript]
} else { } else {
set idxadded [dict get $epoch tm epochs 0 added $indexbase] set idxadded [dict get $epoch tm epochs 0 added $indexbase]
#dict set idxadded $p [dict create e 0 v $v] #dict set idxadded $p [dict create e 0 v $v]
dict set idxadded $p $v e0 dict set idxadded $p $v [dict create e 0 scr $iscript]
dict set epoch tm epochs 0 added $indexbase $idxadded dict set epoch tm epochs 0 added $indexbase $idxadded
} }
dict unset epoch tm untracked $p dict unset epoch tm untracked $p
@ -1395,7 +1449,9 @@ tcl::namespace::eval punk::libunknown {
#} #}
if {![interp issafe]} { if {![interp issafe]} {
#J2
package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown}
#package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::tclPkgUnknown}
} }
} }
@ -1426,10 +1482,26 @@ tcl::namespace::eval punk::libunknown {
dict set r_added $path [dict get $epoch pkg epochs $pkg_epoch added $path] dict set r_added $path [dict get $epoch pkg epochs $pkg_epoch added $path]
} }
#set pkg_added [punk::lib::showdict [dict get $epoch pkg epochs $pkg_epoch added] */$pkgname] #set pkg_added [punk::lib::showdict $r_added */$pkgname]
set pkg_added [punk::lib::showdict $r_added */$pkgname] #set added [textblock::frame -title $title $pkg_added]
set title "PKG epoch $pkg_epoch - added" set rows [list]
set added [textblock::frame -title $title $pkg_added] dict for {path pkgs} $r_added {
set c1 $path
set c2 [dict size $pkgs]
set c3 ""
if {[dict exists $pkgs $pkgname]} {
set vdict [dict get $pkgs $pkgname]
dict for {v data} $vdict {
set scriptlen [string length [dict get $data scr]]
append c3 "$v epoch[dict get $data e] ifneededchars:$scriptlen" \n
}
}
set r [list $path $c2 $c3]
lappend rows $r
}
set title "[punk::ansi::a+ green] PKG epoch $pkg_epoch - added [punk::ansi::a]"
set added [textblock::table -title $title -headers [list Path Pkgcount $pkgname] -rows $rows]
set pkg_row $added set pkg_row $added

45
src/modules/punk/ns-999999.0a1.0.tm
Unescape View File

@ -177,10 +177,10 @@ tcl::namespace::eval punk::ns {
} else { } else {
set fq_nspath $nspath set fq_nspath $nspath
} }
if {[catch {nseval_ifexists $fq_nspath {}}]} { if {[nseval_ifexists $fq_nspath {::string cat ok}] eq "ok"} {
return 0
} else {
return 1 return 1
} else {
return 0
} }
} }
@ -758,7 +758,7 @@ tcl::namespace::eval punk::ns {
} }
set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370] set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370]
if {[llength $ansinames]} { if {[llength $ansinames]} {
return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type][punk::ansi::a]" return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type]\x1b\[0m"
} else { } else {
return [dict get $marks $type] return [dict get $marks $type]
} }
@ -1068,7 +1068,7 @@ tcl::namespace::eval punk::ns {
} else { } else {
} }
if {$cmd in $imported} { if {$cmd in $imported} {
set prefix [overtype::right $prefix "-[a+ yellow bold]I[a+]"] set prefix [overtype::right $prefix "-[a+ yellow bold]I[a]"]
} }
} }
if {$cmd in $usageinfo} { if {$cmd in $usageinfo} {
@ -1076,7 +1076,8 @@ tcl::namespace::eval punk::ns {
} else { } else {
set u "" set u ""
} }
set cmd$i "${prefix} $c$cmd_display$u" #set cmd$i "${prefix} $c$cmd_display$u"
set cmd$i "${prefix} [punk::ansi::ansiwrap -rawansi $c $cmd_display]$u"
#set c$i $c #set c$i $c
set c$i "" set c$i ""
lappend seencmds $cmd lappend seencmds $cmd
@ -3682,6 +3683,21 @@ tcl::namespace::eval punk::ns {
comment inserted to display information such as the comment inserted to display information such as the
namespace origin. Such a comment begins with #corp#." namespace origin. Such a comment begins with #corp#."
@opts @opts
-syntax -default basic -choices {none basic}\
-choicelabels {
none\
" Plain text output"
basic\
" Comment and bracket highlights.
This is a basic colourizer - not
a full Tcl syntax highlighter."
}\
-help\
"Type of syntax highlighting on result.
Note that -syntax none will always return a proper Tcl
List: proc <name> <arglist> <body>
- but a syntax highlighter may return a string that
is not a Tcl list."
@values -min 1 -max -1 @values -min 1 -max -1
commandname -help\ commandname -help\
"May be either the fully qualified path for the command, "May be either the fully qualified path for the command,
@ -3690,7 +3706,8 @@ tcl::namespace::eval punk::ns {
} }
proc corp {args} { proc corp {args} {
set argd [punk::args::parse $args withid ::punk::ns::corp] set argd [punk::args::parse $args withid ::punk::ns::corp]
set path [dict get $argd values commandname] set path [dict get $argd values commandname]
set syntax [dict get $argd opts -syntax]
#thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp #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) #Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name)
if {[info exists punk::console::tabwidth]} { if {[info exists punk::console::tabwidth]} {
@ -3775,7 +3792,19 @@ tcl::namespace::eval punk::ns {
lappend argl $a lappend argl $a
} }
#list proc [nsjoin ${targetns} $name] $argl $body #list proc [nsjoin ${targetns} $name] $argl $body
list proc $resolved $argl $body switch -- $syntax {
basic {
#rudimentary colourising only
set argl [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl]
set body [punk::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one.
set body [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $body]
set body [punk::grepstr -return all -highlight tk-orange {\[|\]} $body]
#ansi colourised items in list format may not always have desired string representation (list escaping can occur)
#return as a string - which may not be a proper Tcl list!
return "proc $resolved {$argl} {\n$body\n}"
}
}
list proc $resolved $argl $body
} }

53
src/modules/punk/packagepreference-999999.0a1.0.tm
Unescape View File

@ -194,7 +194,7 @@ tcl::namespace::eval punk::packagepreference {
if {!$is_exact && [llength $vwant] <= 1 } { if {!$is_exact && [llength $vwant] <= 1 } {
#required version unspecified - or specified singularly #required version unspecified - or specified singularly
set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg] set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg]
if {[llength $available_versions] > 1} { if {[llength $available_versions] >= 1} {
# --------------------------------------------------------------- # ---------------------------------------------------------------
#An attempt to detect dll/so loaded and try to load same version #An attempt to detect dll/so loaded and try to load same version
#dll/so files are often named with version numbers that don't contain dots or a version number at all #dll/so files are often named with version numbers that don't contain dots or a version number at all
@ -202,9 +202,11 @@ tcl::namespace::eval punk::packagepreference {
set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg] set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg]
if {[llength $pkgloadedinfo]} { if {[llength $pkgloadedinfo]} {
puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" if {[llength $available_versions] > 1} {
lassign $pkgloadedinfo path name puts stderr "--> pkg $pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and [llength $available_versions] versions available"
set lcpath [string tolower $path] }
lassign $pkgloadedinfo loaded_path name
set lc_loadedpath [string tolower $loaded_path]
#first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement. #first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement.
set lcpath_to_version [dict create] set lcpath_to_version [dict create]
foreach av $available_versions { foreach av $available_versions {
@ -212,17 +214,19 @@ tcl::namespace::eval punk::packagepreference {
#ifneeded script not always a valid tcl list #ifneeded script not always a valid tcl list
if {![catch {llength $scr} scrlen]} { if {![catch {llength $scr} scrlen]} {
if {$scrlen == 3 && [lindex $scr 0] eq "load" && [string match -nocase [lindex $scr 2] $pkg]} { if {$scrlen == 3 && [lindex $scr 0] eq "load" && [string match -nocase [lindex $scr 2] $pkg]} {
#a basic 'load <path> <pkg>' statement
dict set lcpath_to_version [string tolower [lindex $scr 1]] $av dict set lcpath_to_version [string tolower [lindex $scr 1]] $av
} }
} }
} }
if {[dict exists $lcpath_to_version $lcpath]} { if {[dict exists $lcpath_to_version $lc_loadedpath]} {
set lversion [dict get $lcpath_to_version $lcpath] set lversion [dict get $lcpath_to_version $lc_loadedpath]
} else { } else {
#fallback to a best effort guess based on the path #fallback to a best effort guess based on the path
set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg] set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $loaded_path $pkg]
} }
#puts "====lcpath_to_version: $lcpath_to_version"
if {$lversion ne ""} { if {$lversion ne ""} {
#name matches pkg #name matches pkg
#hack for known dll version mismatch #hack for known dll version mismatch
@ -232,8 +236,40 @@ tcl::namespace::eval punk::packagepreference {
if {[llength $vwant] == 1} { if {[llength $vwant] == 1} {
#todo - still check vsatisfies - report a conflict? review #todo - still check vsatisfies - report a conflict? review
} }
return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] #return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
try {
set result [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
} trap {} {emsg eopts} {
#REVIEW - this occurred in punkmagic (rebuild of tclmagic) - probably due to multiple versions of registry
#under different auto_path folders - and mal-ordering in punk::libunknown's tclPkgUnknown
#May be obsolete.. issue still not clear
#A hack for 'couldn't open "<path.dll>": permission denied'
#This happens for example with the tcl9registry13.dll when loading from zipfs - but not in all systems, and not for all dlls.
#exact cause unknown.
#e.g
#%package ifneeded registry 1.3.7
#- load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry
#%load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry
#couldn't open "C:/Users/sleek/AppData/Local/Temp/TCL00003cf8/tcl9registry13.dll": permission denied
#a subsequent load of the path used in the error message works.
#if {[string match "couldn't open \"*\": permission denied" $emsg]} {}
if {[regexp {couldn't open "(.*)":.*permission denied.*} $emsg _ newpath]} {
#Since this is a hack that shouldn't be required - be noisy about it.
puts stderr ">>> $emsg"
puts stderr "punk::packagepreference::require hack: Re-trying load of $pkg with path: $newpath"
return [load $newpath $pkg]
} else {
#puts stderr "??? $emsg"
#dunno - re-raise
return -options $eopts $emsg
}
}
return $result
} }
#else puts stderr "> no version determined for pkg: $pkg loaded_path: $loaded_path"
} }
} }
} }
@ -291,6 +327,7 @@ tcl::namespace::eval punk::packagepreference {
#we should be able to load more specific punk::args pkg based on result of [package present $pkg] #we should be able to load more specific punk::args pkg based on result of [package present $pkg]
catch { catch {
#$COMMANDSTACKNEXT require $pkg {*}$vwant #$COMMANDSTACKNEXT require $pkg {*}$vwant
#j2
$COMMANDSTACKNEXT require punk::args::$dp $COMMANDSTACKNEXT require punk::args::$dp
} }
} }

3
src/modules/punk/pipe-999999.0a1.0.tm
Unescape View File

@ -373,6 +373,7 @@ tcl::namespace::eval punk::pipe::lib {
if {$end_var_posn > 0} { if {$end_var_posn > 0} {
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead.
#lassign [scan $token %${end_var_posn}s%s] var spec #lassign [scan $token %${end_var_posn}s%s] var spec
#lassign [punk::lib::string_splitbefore $token $end_var_posn] var spec
set var [string range $token 0 $end_var_posn-1] set var [string range $token 0 $end_var_posn-1]
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec
} else { } else {
@ -430,7 +431,7 @@ tcl::namespace::eval punk::pipe::lib {
} }
#if {[string length $token]} { #if {[string length $token]} {
# #lappend varlist [splitstrposn $token $end_var_posn] # #lappend varlist [punk::lib::string_splitbefore $token $end_var_posn]
# set var $token # set var $token
# set spec "" # set spec ""
# if {$end_var_posn > 0} { # if {$end_var_posn > 0} {

6
src/modules/punk/repl-999999.0a1.0.tm
Unescape View File

@ -2472,7 +2472,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
set h [textblock::height $text] set h [textblock::height $text]
set promptcol [string repeat $resultprompt\n $h] set promptcol [string repeat $resultprompt\n $h]
set promptcol [string range $promptcol 0 end-1] set promptcol [string range $promptcol 0 end-1]
rputs [textblock::join_basic -- $promptcol $text] #rputs [textblock::join_basic -- $promptcol $text]
rputs [textblock::join_basic_raw $promptcol $text]
#puts -nonewline stdout $text #puts -nonewline stdout $text
} }
@ -2530,7 +2531,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
set promptcol [string repeat $resultprompt\n $h] set promptcol [string repeat $resultprompt\n $h]
set promptcol [string range $promptcol 0 end-1] set promptcol [string range $promptcol 0 end-1]
#promptcol is uniform-width lines, result may not be. We are ok to join with ragged rhs col here, so use join_basic instead of join #promptcol is uniform-width lines, result may not be. We are ok to join with ragged rhs col here, so use join_basic instead of join
rputs [textblock::join_basic -- $promptcol $result] #rputs [textblock::join_basic -- $promptcol $result]
rputs [textblock::join_basic_raw $promptcol $result]
#orig #orig
#rputs $resultprompt[string map [list \r\n "\n$resultprompt" \n "\n$resultprompt"] $result] #rputs $resultprompt[string map [list \r\n "\n$resultprompt" \n "\n$resultprompt"] $result]

25
src/modules/shellfilter-0.2.tm
Unescape View File

@ -735,6 +735,7 @@ namespace eval shellfilter::chan {
variable o_encbuf ;#buffering for partial encoding bytes variable o_encbuf ;#buffering for partial encoding bytes
variable o_colour variable o_colour
variable o_do_colour variable o_do_colour
variable o_do_colourlist
variable o_do_normal variable o_do_normal
variable o_is_junction variable o_is_junction
variable o_codestack variable o_codestack
@ -747,11 +748,17 @@ namespace eval shellfilter::chan {
set settingsdict [tcl::dict::get $tf -settings] set settingsdict [tcl::dict::get $tf -settings]
if {[tcl::dict::exists $settingsdict -colour]} { if {[tcl::dict::exists $settingsdict -colour]} {
set o_colour [tcl::dict::get $settingsdict -colour] set o_colour [tcl::dict::get $settingsdict -colour]
set o_do_colour [punk::ansi::a+ {*}$o_colour] #warning - we can't merge certain extended attributes such as undercurly into single SGR escape sequence
#while some terminals may handle these extended attributes even when merged - we need to cater for those that
#don't. Keeping them as a separate escape allows terminals that don't handle them to ignore just that code without
#affecting the interpretation of the other codes.
set o_do_colour [punk::ansi::a+ {*}$o_colour]
set o_do_colourlist [punk::ansi::ta::get_codes_single $o_do_colour]
set o_do_normal [punk::ansi::a] set o_do_normal [punk::ansi::a]
} else { } else {
set o_colour {} set o_colour {}
set o_do_colour "" set o_do_colour ""
set o_do_colourlist {}
set o_do_normal "" set o_do_normal ""
} }
set o_codestack [list] set o_codestack [list]
@ -793,11 +800,11 @@ namespace eval shellfilter::chan {
set o_codestack [list] set o_codestack [list]
} else { } else {
#append emit [lindex $o_codestack 0]$pt #append emit [lindex $o_codestack 0]$pt
append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$pt
} }
} }
default { default {
append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$pt
} }
} }
#if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} {
@ -864,11 +871,11 @@ namespace eval shellfilter::chan {
set o_codestack [list] set o_codestack [list]
} else { } else {
#append emit [lindex $o_codestack 0]$trailing_pt #append emit [lindex $o_codestack 0]$trailing_pt
append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$trailing_pt
} }
} }
default { default {
append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$trailing_pt
} }
} }
#if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} {
@ -957,12 +964,12 @@ namespace eval shellfilter::chan {
set o_codestack [list] set o_codestack [list]
} else { } else {
#set emit [lindex $o_codestack 0]$buf #set emit [lindex $o_codestack 0]$buf
set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf
} }
} }
default { default {
#set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf
set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf
} }
} }
#if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} {
@ -987,12 +994,12 @@ namespace eval shellfilter::chan {
set o_codestack [list] set o_codestack [list]
} else { } else {
#set emit [lindex $o_codestack 0]$buf #set emit [lindex $o_codestack 0]$buf
set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf
} }
} }
default { default {
#set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf
set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf
} }
} }
set o_buffered "" set o_buffered ""

93
src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test
Unescape View File

@ -131,6 +131,45 @@ namespace eval ::testspace {
{0 a 1 b 2 c} {3 d} {0 a 1 b 2 c} {3 d}
] ]
test parse_withdef_leaderclause_trailing_optional_members_followed_by_value {Test that last leader clause with optional members works with following required value}\
-setup $common -body {
set argd [punk::args::parse {a z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val]
lappend result [dict get $argd leaders]
set argd [punk::args::parse {a 1 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val]
lappend result [dict get $argd leaders]
set argd [punk::args::parse {a 1 2 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val]
lappend result [dict get $argd leaders]
}\
-cleanup {
}\
-result [list\
{ldr {a {} {}}}\
{ldr {a 1 {}}}\
{ldr {a 1 2}}\
]
test parse_withdef_leaderclause_trailing_optional_members_followed_by_optional_leader_and_value {Test that last leader clause with optional members works with following required value}\
-setup $common -body {
set argd [punk::args::parse {x y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val]
lappend result [dict get $argd leaders]
set argd [punk::args::parse {x 1 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val]
lappend result [dict get $argd leaders]
set argd [punk::args::parse {x 1 y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val]
lappend result [dict get $argd leaders]
set argd [punk::args::parse {x 1 2 y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val]
lappend result [dict get $argd leaders]
}\
-cleanup {
}\
-result [list\
{ldr {x {} {}} ldr2 y}\
{ldr {x 1 {}}}\
{ldr {x 1 {}} ldr2 y}\
{ldr {x 1 2} ldr2 y}\
]
test parse_withdef_value_clause_typedefaults {test clause with optional element and -typedefaults specified}\ test parse_withdef_value_clause_typedefaults {test clause with optional element and -typedefaults specified}\
-setup $common -body { -setup $common -body {
set argd [punk::args::parse {1} withdef @values {v -type {int ?int?} -typedefaults {"" 12}}] set argd [punk::args::parse {1} withdef @values {v -type {int ?int?} -typedefaults {"" 12}}]
@ -191,6 +230,40 @@ namespace eval ::testspace {
{elseifclause {elseif 1 {} x}} {elseifclause {elseif 1 {} x}}
] ]
test parse_withdef_value_clause_missing_optional_multiple {test -multiple true clauses with optional members}\
-setup $common -body {
#this test is applicable to situations such as the elseif clause in the ::if definition:
#e.g literal(elseif) expr ?literal(then)? script
#the 'then' needs to be omitable arbitrarily in a list of elseif clauses
#first test with all values supplied
set argd [punk::args::parse {x 1 y x 2 y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}]
lappend result [dict get $argd values]
#missing value in second instance only
set argd [punk::args::parse {x 1 y x y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}]
lappend result [dict get $argd values]
#missing value in first instance only
#this can trigger a problem whereby the missing value in the first instance (which is empty string) gets processed in validation against 'int' and fails.
#(updating of required type to a validationless value such as ... ?omitted-int? ... needs to be tied to specific clause instances)
set argd [punk::args::parse {x y x 2 y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}]
lappend result [dict get $argd values]
#for completeness - no optional values supplid
set argd [punk::args::parse {x y x y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{triple {{x 1 y} {x 2 y}}}\
{triple {{x 1 y} {x {} y}}}\
{triple {{x {} y} {x 2 y}}}\
{triple {{x {} y} {x {} y}}}\
]
test parse_withdef_value_clause_arity2 {Test value clause result with missing optional member in optional clauses at tail}\ test parse_withdef_value_clause_arity2 {Test value clause result with missing optional member in optional clauses at tail}\
-setup $common -body { -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}] 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}]
@ -213,6 +286,7 @@ namespace eval ::testspace {
{arg {1 2} X {x 1} Y {y 2}} {arg {1 2} X {x 1} Y {y 2}}
] ]
#todo - test L1 parsed to Lit1 not arg #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} #punk::args::parse {x y L1} withdef @values (arg -multiple 1) {lit1 -type literal(L1) -optional 1} {lit2 -type literal(L2) -optional 1}
@ -251,10 +325,10 @@ namespace eval ::testspace {
#see for example ::tcl::dict::create which has a clause length of 2 #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]} { 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] set expected [dict get $eopts -errorcode]
if {[lindex $expected 0] eq "PUNKARGS" && [lindex $expected 1] eq "VALIDATION" && [lindex $expected 2 0] eq "clausevaluelength"} { if {[lindex $expected 0] eq "PUNKARGS" && [lindex $expected 1] eq "VALIDATION" && [lindex $expected 2 0] eq "missingrequiredvalue"} {
lappend result "RECEIVED_EXPECTED_ERROR" lappend result "RECEIVED_EXPECTED_ERROR"
} else { } else {
lappend result "WRONG_ERROR_RECEIVED - $expected (expected PUNKARGS VALIDATION {clausevaluelength ...} ..." lappend result "WRONG_ERROR_RECEIVED - $expected (expected PUNKARGS VALIDATION {missingrequiredvalue ...} ..."
} }
} else { } else {
lappend result "MISSING_REQUIRED_ERROR" lappend result "MISSING_REQUIRED_ERROR"
@ -279,18 +353,6 @@ namespace eval ::testspace {
{-direction u} {-direction u}
] ]
test parse_withdef_choice_multiple_multiple {test -choice with both -multiple and -choicemultiple}\
-setup $common -body {
set argd [punk::args::parse {a {c a} {a b c}} withdef @values {X -type string -choices {aa bb cc} -multiple 1 -choicemultiple {1 3} -optional 1}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{X {aa {cc aa} {aa bb cc}}}
]
#todo - decide on whether -choicemultiple should disallow duplicates in result by default
test parse_withdef_leader_literalprefix_fullvalue {leaders - ensure supplying a prefix of literalprefix(test) returns full value 'test'}\ test parse_withdef_leader_literalprefix_fullvalue {leaders - ensure supplying a prefix of literalprefix(test) returns full value 'test'}\
-setup $common -body { -setup $common -body {
set argd [punk::args::parse {t} withdef @leaders {A -type literalprefix(test)}] set argd [punk::args::parse {t} withdef @leaders {A -type literalprefix(test)}]
@ -356,4 +418,7 @@ namespace eval ::testspace {
-result [list\ -result [list\
{A a} {A 11} {A a} {A 11}
] ]
} }

158
src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/choices.test
Unescape View File

@ -0,0 +1,158 @@
package require tcltest
namespace eval ::testspace {
namespace import ::tcltest::*
variable common {
set result ""
}
test choices_typeignored_when_choice_in_list {Test that -type is not validated for a value that matches a choice}\
-setup $common -body {
#1 abbreviated choice
set argd [punk::args::parse {li} withdef @values {frametype -type dict -choices {heavy light arc}}]
lappend result [dict get $argd values]
#2 exact match for a choice
set argd [punk::args::parse {light} withdef @values {frametype -type dict -choices {heavy light arc}}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{frametype light}\
{frametype light}\
]
test choices_type_validation_choicerestricted1 {Test that -type is validated for value outside of choicelist based on -choicerestricted}\
-setup $common -body {
set argd [punk::args::parse {11} withdef @values {frametype -type int -choicerestricted 0 -choices {heavy light arc}}]
lappend result [dict get $argd values]
if {[catch {
punk::args::parse {z} withdef @values {frametype -type int -choicerestricted 0 -choices {heavy light arc}}
}]} {
lappend result "ok_got_expected_error1"
} else {
lappend result "missing_required_error_when_type_mismatch_for_choice_outside_list"
}
#when -choicerestricted - value matching -type still shouldn't pass
if {[catch {
set argd [punk::args::parse {11} withdef @values {frametype -type int -choicerestricted 1 -choices {heavy light arc}}]
}]} {
lappend result "ok_got_expected_error2"
} else {
lappend result "missing_required_error_when_choicerestricted_and_choice_outside_list"
}
}\
-cleanup {
}\
-result [list\
{frametype 11}\
ok_got_expected_error1\
ok_got_expected_error2\
]
test choices_type_validation_choicerestricted2 {Test that -type dict is validated for value outside of choicelist based on -choicerestricted}\
-setup $common -body {
#same as choices_type_validation_choicrestricted1 - but with a more complex type 'dict' - tests list protection is correct
set argd [punk::args::parse {{hl -}} withdef @values {frametype -type dict -choicerestricted 0 -choices {heavy light arc}}]
lappend result [dict get $argd values]
if {[catch {
punk::args::parse {z} withdef @values {frametype -type dict -choicerestricted 0 -choices {heavy light arc}}
}]} {
lappend result "ok_got_expected_error1"
} else {
lappend result "missing_required_error_when_type_mismatch_for_choice_outside_list"
}
#when -choicerestricted - value matching -type dict still shouldn't pass
if {[catch {
set argd [punk::args::parse {{hl -}} withdef @values {frametype -type dict -choicerestricted 1 -choices {heavy light arc}}]
}]} {
lappend result "ok_got_expected_error2"
} else {
lappend result "missing_required_error_when_choicerestricted_and_choice_outside_list"
}
}\
-cleanup {
}\
-result [list\
{frametype {hl -}}\
ok_got_expected_error1\
ok_got_expected_error2\
]
test choice_multiple_multiple {test -choice with both -multiple and -choicemultiple}\
-setup $common -body {
set argd [punk::args::parse {a {c a} {a b c}} withdef @values {X -type string -choices {aa bb cc} -multiple 1 -choicemultiple {1 3} -optional 1}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{X {aa {cc aa} {aa bb cc}}}
]
#todo - decide on whether -choicemultiple should disallow duplicates in result by default
test choice_multielement_clause {test -choice with a clause-length greater than 1}\
-setup $common -body {
#The same -choices list always applies to each member of -type - which isn't always ideal for a multi-element clause
#for a clause where each element has a different choiceset - we would need to introduce a more complex -typechoices option
#(or use a -parsekey mechanism on leaders/values to group them)
#test all combinations of prefix and complete for 2 entries
set argd [punk::args::parse {light heavy} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}]
lappend result [dict get $argd values]
set argd [punk::args::parse {li heavy} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}]
lappend result [dict get $argd values]
set argd [punk::args::parse {li he} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}]
lappend result [dict get $argd values]
set argd [punk::args::parse {light he} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{leftright {light heavy}}\
{leftright {light heavy}}\
{leftright {light heavy}}\
{leftright {light heavy}}\
]
test choice_multielement_clause_unrestricted {test -choice with a clause-length greater than 1 and values outside of choicelist}\
-setup $common -body {
#1 both values outside of -choices
set argd [punk::args::parse {11 x} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}]
lappend result [dict get $argd values]
#
set argd [punk::args::parse {11 arc} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}]
lappend result [dict get $argd values]
#
set argd [punk::args::parse {11 a} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}]
lappend result [dict get $argd values]
#
set argd [punk::args::parse {heavy x} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}]
lappend result [dict get $argd values]
#
set argd [punk::args::parse {h x} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}]
lappend result [dict get $argd values]
#
set argd [punk::args::parse {a h} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{leftright {11 x}}\
{leftright {11 arc}}\
{leftright {11 arc}}\
{leftright {heavy x}}\
{leftright {heavy x}}\
{leftright {arc heavy}}\
]
}

76
src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/opts.test
Unescape View File

@ -0,0 +1,76 @@
package require tcltest
namespace eval ::testspace {
namespace import ::tcltest::*
variable common {
set result ""
}
test opts_longoptvalue {Test -alt|--longopt= can accept value as longopt}\
-setup $common -body {
set argd [punk::args::parse {--filename=abc} withdef @opts {-f|--filename= -default spud -type string}]
lappend result [dict get $argd opts];#name by default should be last flag alternative (stripped of =) ie "--filename"
}\
-cleanup {
}\
-result [list\
{--filename abc}\
]
test opts_longoptvalue_alternative {Test -alt|--longopt= can accept value as spaced argument to given alternative}\
-setup $common -body {
#test full name of alt flag
set argd [punk::args::parse {-fx xyz} withdef @opts {-fx|--filename= -default spud -type string}]
lappend result [dict get $argd opts] ;#name by default should be last flag alternative (stripped of =) ie "--filename"
#test prefixed version of flag
set argd [punk::args::parse {-f xyz} withdef @opts {-fx|--filename= -default spud -type string}]
lappend result [dict get $argd opts]
}\
-cleanup {
}\
-result [list\
{--filename xyz}\
{--filename xyz}\
]
test opts_longoptvalue_alternative_noninterference {Test -alt|--longopt= can accept longopt values as normal }\
-setup $common -body {
#test full name of longopt
set argd [punk::args::parse {--filename=xyz} withdef @opts {-fx|--filename= -default spud -type string}]
lappend result [dict get $argd opts] ;#name by default should be last flag alternative (stripped of =) ie "--filename"
#test prefixed version of longopt
set argd [punk::args::parse {--file=xyz} withdef @opts {-fx|--filename= -default spud -type string}]
lappend result [dict get $argd opts]
}\
-cleanup {
}\
-result [list\
{--filename xyz}\
{--filename xyz}\
]
test opts_longoptvalue_choice {Test --longopt= works wiith -choices}\
-setup $common -body {
#prefixed choice with and without prefixed flagname
set argd [punk::args::parse {--filename=x} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}]
lappend opts [dict get $argd opts]
set argd [punk::args::parse {--file=x} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}]
lappend opts [dict get $argd opts]
#unprefixed choice with and without prefixed flagname
set argd [punk::args::parse {--filename=xyz} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}]
lappend opts [dict get $argd opts]
set argd [punk::args::parse {--file=xyz} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}]
lappend opts [dict get $argd opts]
}\
-cleanup {
}\
-result [list\
{--filename xyz}\
{--filename xyz}\
{--filename xyz}\
{--filename xyz}\
]
}

0
src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/synopsis.test#..+args+synopsis.test.fauxlink
Unescape View File

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

@ -2313,7 +2313,8 @@ tcl::namespace::eval textblock {
#JMN #JMN
#spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic
set spanned_frame [textblock::join_basic -- {*}$spanned_parts] #set spanned_frame [textblock::join_basic -- {*}$spanned_parts]
set spanned_frame [textblock::join_basic_raw {*}$spanned_parts]
if {$spans_to_rhs} { if {$spans_to_rhs} {
if {$cidx == 0} { if {$cidx == 0} {
@ -2382,7 +2383,8 @@ tcl::namespace::eval textblock {
} else { } else {
#this_span == 1 #this_span == 1
set spanned_frame [textblock::join_basic -- $header_cell_startspan] #set spanned_frame [textblock::join_basic -- $header_cell_startspan]
set spanned_frame [textblock::join_basic_raw $header_cell_startspan]
} }
@ -4011,7 +4013,8 @@ tcl::namespace::eval textblock {
set body_build "" set body_build ""
} else { } else {
#body blocks should not be ragged - so can use join_basic #body blocks should not be ragged - so can use join_basic
set body_build [textblock::join_basic -- {*}$body_blocks] #set body_build [textblock::join_basic -- {*}$body_blocks]
set body_build [textblock::join_basic_raw {*}$body_blocks]
} }
if {$headerheight > 0} { if {$headerheight > 0} {
set table [tcl::string::cat $header_build \n $body_build] set table [tcl::string::cat $header_build \n $body_build]
@ -4662,7 +4665,8 @@ tcl::namespace::eval textblock {
if {[tcl::string::last \n $charblock] >= 0} { if {[tcl::string::last \n $charblock] >= 0} {
if {$blockwidth > 1} { if {$blockwidth > 1} {
#set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks )
set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] #set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]]
set row [textblock::join_basic_raw {*}[lrepeat $blockwidth $charblock]]
} else { } else {
set row $charblock set row $charblock
} }
@ -4780,7 +4784,8 @@ tcl::namespace::eval textblock {
if {"noreset" in $colour} { if {"noreset" in $colour} {
return [textblock::join_basic -ansiresets 0 -- {*}$clist] return [textblock::join_basic -ansiresets 0 -- {*}$clist]
} else { } else {
return [textblock::join_basic -- {*}$clist] #return [textblock::join_basic -- {*}$clist]
return [textblock::join_basic_raw {*}$clist]
} }
} elseif {"rainbow" in $colour} { } elseif {"rainbow" in $colour} {
#direction must be horizontal #direction must be horizontal
@ -5037,19 +5042,20 @@ tcl::namespace::eval textblock {
-width ""\ -width ""\
-overflow 0\ -overflow 0\
-within_ansi 0\ -within_ansi 0\
-return block\
] ]
#known_samewidth of empty string means we don't know either way, 0 is definitely 'ragged', 1 is definitely homogenous #known_samewidth of empty string means we don't know either way, 0 is definitely 'ragged', 1 is definitely homogenous
#review!? #review!?
#-within_ansi means after a leading ansi code when doing left pad on all but last line #-within_ansi means after a leading ansi code when doing left pad on all but last line
#-within_ansi means before a trailing ansi code when doing right pad on all but last line #-within_ansi means before a trailing ansi code when doing right pad on all but last line
set usage "pad block ?-padchar <sp>|<character>? ?-which right|left|centre? ?-known_hasansi \"\"|<bool>? ?-known_blockwidth \"\"|<int>? ?-width auto|<int>? ?-within_ansi 1|0?"
foreach {k v} $args { foreach {k v} $args {
switch -- $k { switch -- $k {
-padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi - -return {
tcl::dict::set opts $k $v tcl::dict::set opts $k $v
} }
default { default {
set usage "pad block ?-padchar <sp>|<character>? ?-which right|left|centre? ?-known_hasansi \"\"|<bool>? ?-known_blockwidth \"\"|<int>? ?-width auto|<int>? ?-within_ansi 1|0? ?-return block|list?"
error "textblock::pad unrecognised option '$k'. Usage: $usage" error "textblock::pad unrecognised option '$k'. Usage: $usage"
} }
} }
@ -5195,96 +5201,110 @@ tcl::namespace::eval textblock {
set line_len 0 set line_len 0
set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad
foreach {pt ansi} $parts { foreach {pt ansi} $parts {
if {$pt ne ""} { if {$pt eq ""} {
set has_nl [expr {[tcl::string::last \n $pt]>=0}] #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes
if {$has_nl} { lappend line_chunks ""
} elseif {[tcl::string::last \n $pt]==-1} {
lappend line_chunks $pt
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
incr line_len [punk::char::grapheme_width_cached $pt] ;#memleak - REVIEW
}
} else {
#set has_nl [expr {[tcl::string::last \n $pt]>=0}]
#if {$has_nl} {
set pt [tcl::string::map [list \r\n \n] $pt] set pt [tcl::string::map [list \r\n \n] $pt]
set partlines [split $pt \n] set partlines [split $pt \n]
} else { #} else {
set partlines [list $pt] # set partlines [list $pt]
} #}
set last [expr {[llength $partlines]-1}] #set last [expr {[llength $partlines]-1}]
set p 0 #set p -1
foreach pl $partlines { foreach pl [lrange $partlines 0 end-1] {
lappend line_chunks $pl #incr p
lappend line_chunks $pl ;#we need to lappend because there can already be some pt and ansi entries for the current line from previous {pt ansi} values where pt had no newline.
#incr line_len [punk::char::ansifreestring_width $pl] #incr line_len [punk::char::ansifreestring_width $pl]
#if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
# incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
#}
#do padding
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
set missing [expr {$width - $line_len}]
} else {
set missing [expr {$width - $datawidth}]
} }
if {$p != $last} { if {$missing > 0} {
#do padding #commonly in a block - many lines will have the same pad - cache based on missing
if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} {
set missing [expr {$width - $line_len}]
} else {
set missing [expr {$width - $datawidth}]
}
if {$missing > 0} {
#commonly in a block - many lines will have the same pad - cache based on missing
#padchar may be more than 1 wide - because of 2wide unicode and or multiple chars #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars
if {[tcl::dict::exists $pad_cache $missing]} { if {[tcl::dict::exists $pad_cache $missing]} {
set pad [tcl::dict::get $pad_cache $missing] set pad [tcl::dict::get $pad_cache $missing]
} else {
set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width
if {!$pad_has_ansi} {
set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1]
} else { } else {
set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width set base [tcl::string::repeat " " $missing]
if {!$pad_has_ansi} { set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]]
set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1]
} else {
set base [tcl::string::repeat " " $missing]
set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]]
}
dict set pad_cache $missing $pad
} }
switch -- $which-$opt_withinansi { dict set pad_cache $missing $pad
r-0 { }
lappend line_chunks $pad switch -- $which-$opt_withinansi {
} r-0 {
r-1 { lappend line_chunks $pad
if {[lindex $line_chunks end] eq ""} { }
set line_chunks [linsert $line_chunks end-2 $pad] r-1 {
} else { if {[lindex $line_chunks end] eq ""} {
lappend line_chunks $pad set line_chunks [linsert $line_chunks end-2 $pad]
} } else {
}
r-2 {
lappend line_chunks $pad lappend line_chunks $pad
} }
l-0 { }
set line_chunks [linsert $line_chunks 0 $pad] r-2 {
lappend line_chunks $pad
}
l-0 {
set line_chunks [linsert $line_chunks 0 $pad]
}
l-1 {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
} else {
set line_chunks [linsert $line_chunks 0 $pad]
} }
l-1 { }
l-2 {
if {$lnum == 0} {
if {[lindex $line_chunks 0] eq ""} { if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad] set line_chunks [linsert $line_chunks 2 $pad]
} else { } else {
set line_chunks [linsert $line_chunks 0 $pad] set line_chunks [linsert $line_chunks 0 $pad]
} }
} } else {
l-2 { set line_chunks [linsert $line_chunks 0 $pad]
if {$lnum == 0} {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
} else {
set line_chunks [linsert $line_chunks 0 $pad]
}
} else {
set line_chunks [linsert $line_chunks 0 $pad]
}
} }
} }
} }
lappend lines [::join $line_chunks ""]
set line_chunks [list]
set line_len 0
incr lnum
} }
incr p lappend lines [::join $line_chunks ""]
set line_chunks [list]
set line_len 0
incr lnum
} }
} else { #deal with last part zzz of xxx\nyyy\nzzz - not yet a complete line
#we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes set pl [lindex $partlines end]
lappend line_chunks "" lappend line_chunks $pl ;#we need to lappend because there can already be some pt and ansi entries for the current line from previous {pt ansi} values where pt had no newline.
if {$pl ne "" && ($known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq "")} {
incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW
}
} }
#don't let trailing empty ansi affect the line_chunks length #don't let trailing empty ansi affect the line_chunks length
if {$ansi ne ""} { if {$ansi ne ""} {
lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? lappend line_chunks $ansi ;#don't update line_len
#- review - ansi codes with visible content?
#- There shouldn't be any, even though for example some terminals display PM content
#e.g OSC 8 is ok as it has the uri 'inside' the ansi sequence, but that's ok because the displayable part is outside and is one of our pt values from split_codes.
} }
} }
#pad last line #pad last line
@ -5343,7 +5363,11 @@ tcl::namespace::eval textblock {
} }
} }
lappend lines [::join $line_chunks ""] lappend lines [::join $line_chunks ""]
return [::join $lines \n] if {[tcl::dict::get $opts -return] eq "block"} {
return [::join $lines \n]
} else {
return $lines
}
} }
#left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single
@ -5620,6 +5644,33 @@ tcl::namespace::eval textblock {
} }
return [::join $outlines \n] return [::join $outlines \n]
} }
proc ::textblock::join_basic_raw {args} {
#no options. -*, -- are legimate blocks
set blocklists [lrepeat [llength $args] ""]
set blocklengths [lrepeat [expr {[llength $args]+1}] 0] ;#add 1 to ensure never empty - used only for rowcount max calc
set i -1
foreach b $args {
incr i
if {[punk::ansi::ta::detect $b]} {
#-ansireplays 1 quite expensive e.g 7ms in 2024
set blines [punk::lib::lines_as_list -ansireplays 1 -ansiresets auto -- $b]
} else {
set blines [split $b \n]
}
lset blocklengths $i [llength $blines]
lset blocklists $i $blines
}
set rowcount [tcl::mathfunc::max {*}$blocklengths]
set outlines [lrepeat $rowcount ""]
for {set r 0} {$r < $rowcount} {incr r} {
set row ""
foreach blines $blocklists {
append row [lindex $blines $r]
}
lset outlines $r $row
}
return [::join $outlines \n]
}
proc ::textblock::join_basic2 {args} { proc ::textblock::join_basic2 {args} {
#@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width.
# Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
@ -5704,9 +5755,12 @@ tcl::namespace::eval textblock {
} }
set idx 0 set idx 0
set blocklists [list] #set blocklists [list]
set blocklists [lrepeat [llength $blocks] ""]
set rowcount 0 set rowcount 0
set bidx -1
foreach b $blocks { foreach b $blocks {
incr bidx
#we need the width of a rendered block for per-row renderline calls or padding #we need the width of a rendered block for per-row renderline calls or padding
#we may as well use widthinfo to also determine raggedness state to pass on to pad function #we may as well use widthinfo to also determine raggedness state to pass on to pad function
#set bwidth [width $b] #set bwidth [width $b]
@ -5723,18 +5777,21 @@ tcl::namespace::eval textblock {
if {[punk::ansi::ta::detect $b]} { if {[punk::ansi::ta::detect $b]} {
# - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?) # - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?)
set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n] set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n]
set bl [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] #set blines [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
set blines [textblock::pad $replay_block -return lines -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "]
} else { } else {
#each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi
set bl [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] #set blines [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n]
set blines [textblock::pad $b -return lines -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "]
} }
set rowcount [expr {max($rowcount,[llength $bl])}] set rowcount [expr {max($rowcount,[llength $blines])}]
lappend blocklists $bl #lappend blocklists $bl
lset blocklists $bidx $blines
set width($idx) $bwidth set width($idx) $bwidth
incr idx incr idx
} }
set outlines [list] set outlines [lrepeat $rowcount ""]
for {set r 0} {$r < $rowcount} {incr r} { for {set r 0} {$r < $rowcount} {incr r} {
set row "" set row ""
for {set c 0} {$c < [llength $blocklists]} {incr c} { for {set c 0} {$c < [llength $blocklists]} {incr c} {
@ -5744,7 +5801,8 @@ tcl::namespace::eval textblock {
} }
append row $cell append row $cell
} }
lappend outlines $row #lappend outlines $row
lset outlines $r $row
} }
return [::join $outlines \n] return [::join $outlines \n]
} }
@ -6224,9 +6282,11 @@ tcl::namespace::eval textblock {
set spec [string map [list <ftlist> $::textblock::frametypes] { set spec [string map [list <ftlist> $::textblock::frametypes] {
@id -id ::textblock::framedef @id -id ::textblock::framedef
@cmd -name textblock::framedef\ @cmd -name textblock::framedef\
-summary "Return frame graphical elements as a dictionary."\
-help "Return a dict of the elements that make up a frame border. -help "Return a dict of the elements that make up a frame border.
May return a subset of available elements based on memberglob values." May return a subset of available elements based on memberglob values."
@leaders -min 0 -max 0
@opts
-joins -default "" -type list\ -joins -default "" -type list\
-help "List of join directions, any of: up down left right -help "List of join directions, any of: up down left right
or those combined with another frametype e.g left-heavy down-light." or those combined with another frametype e.g left-heavy down-light."
@ -6234,7 +6294,7 @@ tcl::namespace::eval textblock {
-help "-boxonly true restricts results to the corner,vertical and horizontal box elements -help "-boxonly true restricts results to the corner,vertical and horizontal box elements
It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj."
@values -min 1 @values -min 1 -max -1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\ frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary." -help "name from the predefined frametypes or an adhoc dictionary."
memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
@ -8566,7 +8626,8 @@ tcl::namespace::eval textblock {
#puts "frame--->ansiwrap -rawansi [ansistring VIEW $opt_ansibase] $cache_inner" #puts "frame--->ansiwrap -rawansi [ansistring VIEW $opt_ansibase] $cache_inner"
if {$opt_ansibase ne ""} { if {$opt_ansibase ne ""} {
if {[punk::ansi::ta::detect $cache_inner]} { if {[punk::ansi::ta::detect $cache_inner]} {
set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner] #set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner]
set cache_inner [punk::ansi::ansiwrap_raw $opt_ansibase "" "" $cache_inner]
} else { } else {
set cache_inner "$opt_ansibase$cache_inner\x1b\[0m" set cache_inner "$opt_ansibase$cache_inner\x1b\[0m"
} }
@ -8597,7 +8658,8 @@ tcl::namespace::eval textblock {
#JMN test #JMN test
#assert - lhs, cache_inner, rhs non-ragged - so can use join_basic REVIEW #assert - lhs, cache_inner, rhs non-ragged - so can use join_basic REVIEW
#set cache_body [textblock::join -- {*}$cache_bodyparts] #set cache_body [textblock::join -- {*}$cache_bodyparts]
set cache_body [textblock::join_basic -- {*}$cache_bodyparts] #set cache_body [textblock::join_basic -- {*}$cache_bodyparts]
set cache_body [textblock::join_basic_raw {*}$cache_bodyparts]
append fscached $cache_body append fscached $cache_body
#append fs $body #append fs $body
@ -8658,7 +8720,8 @@ tcl::namespace::eval textblock {
set contents_has_ansi [punk::ansi::ta::detect $contents] set contents_has_ansi [punk::ansi::ta::detect $contents]
if {$opt_ansibase ne ""} { if {$opt_ansibase ne ""} {
if {$contents_has_ansi} { if {$contents_has_ansi} {
set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents] #set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents]
set contents [punk::ansi::ansiwrap_raw $opt_ansibase "" "" $contents]
} else { } else {
set contents "$opt_ansibase$contents\x1b\[0m" set contents "$opt_ansibase$contents\x1b\[0m"
set contents_has_ansi 1 set contents_has_ansi 1

Write Preview
Loading…
Cancel
Save