#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
#Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
set str "Ẓ̌á̲l͔̝̞̄̑͌g̖̘̘̔̔͢͞͝o̪̔T̢̙̫̈̍͞e̬͈͕͌̏͑x̺̍ṭ̓̓ͅ"
}
proc test_zalgo2 {} {
# ------------------------
set str "Z̸̢͉̣͔̭̪͙̖̳̘͈͍̤̩̟͈͈͕̯̅̏̆̓̌́́͌̿̕ͅą̷̦̤̫̩͕̥̐̎̓́́̂̀͆́̔̄̈́̏̌́̆͜͜͝͠l̴̩̙̺͚̟͇͖͔͕̹̟͌̈́̄̇́̉̋̕̚͜͠͠g̸͇̩͔̺̝̗̥̖̙̑̈́̈́̿̾̌͌͊̈̀͊̑̇̑͌̍̅̌͊͜͠͝ǫ̴̢̧͎͔̞̤̻̱̮̬͕̗̭͍̣̠̳̆̀̋̓͒̾̄͜͝͠͝T̴̛͉̬̋́̈́̈́̓͗̍̏̔̈̋̀͐̓̎̅̚̕͠͝͝ê̵̖̖̈͊̔̓̔̐̓̃͊̋͋̎͂͋̕x̴̡͎͖̼͎̦͎̲̪̘̺̯̲̬̮̥̼̰͌̃͜ͅt̶̛̘͎̰̔͐͌́̈́͊͗͌̅͂̐̆͌̀͂͘"
# ------------------------
}
proc test_zalgo3 {} {
# ------------------------
set str "Ẕ̸̢̼̺̜̰̣̣̖̭̜͓͖̺̥̼̠͙͙̟̥̟̠̤̫͍̠̤̮͚̝̜̙͈̦̙̩̹̙̜̩̦͔͕̈̃̅̇̈́͂̇̽̈́́́́̎͊̂̑̋͆̔̾͋̚͜ͅã̵̛̪̽̎̃͑̒̇͋͂̽̃̍͊̀̈̊̊̔̊̆̈́͗͑͗̽̄̋͗̄͌̑͊͝͝͠ͅl̵̢͇̖͉͖̝̹̜̞͓͎͍͈̞̱̙͙̦̪͔̱̮͈͉̼͎̭̝̯͇͚̺̟̱͙̳̰̙͚͖̝̫͙̎̅̃͆̈́̋̌̔̋̋͗̈́̔̐͆̈́̓̾̄̀́̏́͒̆̌͒̈́̈́̾̏̀͜͝g̸̖͂͋̊͗̈́̓̆̈̋̒͐̕o̶̧̢͓̲̗̠̘͕̦̤̹̗͉̰͔̯͓̭̹̻͔͇̯̜̙̍̂̃̃̀̓͌̒͊̊̋̒̿̿̌͐̄͗̾̕͝T̶̛̳̜̰͍̹̻̫̠̱̼̼̙̆̑̾̾͛́́̿͋͌̎̀̀̽̆͌̽̂̈̇̅̇̃́̿͗̾͒̎͊̑̾͝͠ȩ̸̢̨̛̛̛̭͔͎͇̫͎͈̲̻̙͕͎̣͈̩̺̗͖͙͇͌͐̒̎͐̓́̉́͐̓̐͌̅̊͋͑̈́͗͑̏̕͜͜͝ͅx̸̧̧̛̖̣̥̘͎͎̳̭̙̦̝͖̝̮̱̹̯̺̙̩̯̮͖̻̰͓̰̩͇̥̑͌̊̐̉̏͆̓̑̎̊̓͒̂̄̆͆̀̊̄̈̽͐͛̏͊̓̌͑́̎̈́̍̈́̊͗̉̋͆̿̊͘͜͜͝͝ͅͅͅt̵̡̨̜̘͎̦͚̠̗̺͉̼̠̲̠͙̺̹̗̲̏̈́̂̚͜͜͝ͅ"
# ------------------------
}
proc test_farmer {} {
proc test_farmer {} {
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
#get info about punk nestindex key ie type: list,dict,undetermined
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
}
proc invoke command {
proc invoke command {
@ -1127,17 +1112,35 @@ namespace eval punk::lib {
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
#get info about punk nestindex key ie type: list,dict,undetermined
# pdict devel
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
#???
}
#*** !doctools
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
}
}
tcl::namespace::eval punk::lib::debug {
proc showdict {args} {}
}
if {![info exists ::punk::args::register::NAMESPACES]} {
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_headerdefs [tcl::dict::create] ;#by header-row
set o_headerstates [tcl::dict::create]
set o_headerstates [tcl::dict::create]
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
}
}
tcl::dict::set result -values $header_row_items
tcl::dict::set result -values $header_row_items
#review - ensure always a headerdef record for each header?
if {[tcl::dict::exists $o_headerdefs $hidx]} {
set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]]
} else {
#warn for now
puts stderr "no headerdef record for header $hidx"
set opt_minh [tcl::dict::get $update_hdefs -minheight]
set opt_maxh [tcl::dict::get $update_hdefs -maxheight]
#todo - allow zero values to hide/collapse
# - see also configure_row
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
}
proc size2 {textblock} {
if {$textblock eq ""} {
return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack
if {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
set lines [split $textblock \n]
set num_le [expr {[llength $lines]-1}]
#set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]]
set width 0
foreach ln $lines {
set w [::punk::char::ansifreestring_width $ln]
if {$w > $width} {
set width $w
}
}
} else {
set num_le 0
set width [punk::char::ansifreestring_width $textblock]
}
#set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list
#our concept of block-height is likely to be different to other line-counting mechanisms
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size_as_opts {textblock} {
proc size_as_opts {textblock} {
set sz [size $textblock]
set sz [size $textblock]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]
#setting -type none indicates a flag that doesn't take a value (solo flag)
#setting -type none indicates a flag that doesn't take a value (solo flag)
-nocomplain -type none
-nocomplain -type none
*values -min 1 -max -1
*values -min 1 -max -1
} $args]] opts values
} $args]] leaders opts values
puts "translation is [dict get $opts -translation]"
puts "translation is [dict get $opts -translation]"
foreach f [dict values $values] {
foreach f [dict values $values] {
@ -47,7 +47,7 @@
}]
}]
[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls
[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls
[para] - the above example would work just fine with only the -<optionname> lines, but would allow zero filenames to be supplied as no -min value is set for *values
[para] - the above example would work just fine with only the -<optionname> lines, but would allow zero filenames to be supplied as no -min value is set for *values
[para]valid * lines being with *proc *opts *values
[para]valid * lines being with *proc *leaders *opts *values
[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument.
[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument.
[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero.
[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero.
[para]e.g the result from the punk::args call above may be something like:
[para]e.g the result from the punk::args call above may be something like:
@ -63,7 +63,7 @@
*values -min 2 -max 2
*values -min 2 -max 2
fileA -type existingfile 1
fileA -type existingfile 1
fileB -type existingfile 1
fileB -type existingfile 1
} $args]] opts values
} $args]] leaders opts values
puts "$category fileA: [dict get $values fileA]"
puts "$category fileA: [dict get $values fileA]"
puts "$category fileB: [dict get $values fileB]"
puts "$category fileB: [dict get $values fileB]"
}
}
@ -164,14 +164,16 @@ For functions that are part of an API a package may be more suitable.
[item] [package {Tcl 8.6-}]
[item] [package {Tcl 8.6-}]
[list_end]
[list_end]
[section API]
[section API]
[subsection {Namespace punk::args::class}]
[subsection {Namespace punk::args}]
[para] class definitions
[para] cooperative namespace punk::args::register
[list_begin enumerated]
[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded
[list_end] [comment {--- end class enumeration ---}]
[para] The punk::args package will then test for a public list variable <namepace>::PUNKARGS containing argument definitions when it needs to.
[list_begin definitions]
[list_end] [comment {--- end definitions namespace punk::args::register ---}]
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
#Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
set str "Ẓ̌á̲l͔̝̞̄̑͌g̖̘̘̔̔͢͞͝o̪̔T̢̙̫̈̍͞e̬͈͕͌̏͑x̺̍ṭ̓̓ͅ"
}
proc test_zalgo2 {} {
# ------------------------
set str "Z̸̢͉̣͔̭̪͙̖̳̘͈͍̤̩̟͈͈͕̯̅̏̆̓̌́́͌̿̕ͅą̷̦̤̫̩͕̥̐̎̓́́̂̀͆́̔̄̈́̏̌́̆͜͜͝͠l̴̩̙̺͚̟͇͖͔͕̹̟͌̈́̄̇́̉̋̕̚͜͠͠g̸͇̩͔̺̝̗̥̖̙̑̈́̈́̿̾̌͌͊̈̀͊̑̇̑͌̍̅̌͊͜͠͝ǫ̴̢̧͎͔̞̤̻̱̮̬͕̗̭͍̣̠̳̆̀̋̓͒̾̄͜͝͠͝T̴̛͉̬̋́̈́̈́̓͗̍̏̔̈̋̀͐̓̎̅̚̕͠͝͝ê̵̖̖̈͊̔̓̔̐̓̃͊̋͋̎͂͋̕x̴̡͎͖̼͎̦͎̲̪̘̺̯̲̬̮̥̼̰͌̃͜ͅt̶̛̘͎̰̔͐͌́̈́͊͗͌̅͂̐̆͌̀͂͘"
# ------------------------
}
proc test_zalgo3 {} {
# ------------------------
set str "Ẕ̸̢̼̺̜̰̣̣̖̭̜͓͖̺̥̼̠͙͙̟̥̟̠̤̫͍̠̤̮͚̝̜̙͈̦̙̩̹̙̜̩̦͔͕̈̃̅̇̈́͂̇̽̈́́́́̎͊̂̑̋͆̔̾͋̚͜ͅã̵̛̪̽̎̃͑̒̇͋͂̽̃̍͊̀̈̊̊̔̊̆̈́͗͑͗̽̄̋͗̄͌̑͊͝͝͠ͅl̵̢͇̖͉͖̝̹̜̞͓͎͍͈̞̱̙͙̦̪͔̱̮͈͉̼͎̭̝̯͇͚̺̟̱͙̳̰̙͚͖̝̫͙̎̅̃͆̈́̋̌̔̋̋͗̈́̔̐͆̈́̓̾̄̀́̏́͒̆̌͒̈́̈́̾̏̀͜͝g̸̖͂͋̊͗̈́̓̆̈̋̒͐̕o̶̧̢͓̲̗̠̘͕̦̤̹̗͉̰͔̯͓̭̹̻͔͇̯̜̙̍̂̃̃̀̓͌̒͊̊̋̒̿̿̌͐̄͗̾̕͝T̶̛̳̜̰͍̹̻̫̠̱̼̼̙̆̑̾̾͛́́̿͋͌̎̀̀̽̆͌̽̂̈̇̅̇̃́̿͗̾͒̎͊̑̾͝͠ȩ̸̢̨̛̛̛̭͔͎͇̫͎͈̲̻̙͕͎̣͈̩̺̗͖͙͇͌͐̒̎͐̓́̉́͐̓̐͌̅̊͋͑̈́͗͑̏̕͜͜͝ͅx̸̧̧̛̖̣̥̘͎͎̳̭̙̦̝͖̝̮̱̹̯̺̙̩̯̮͖̻̰͓̰̩͇̥̑͌̊̐̉̏͆̓̑̎̊̓͒̂̄̆͆̀̊̄̈̽͐͛̏͊̓̌͑́̎̈́̍̈́̊͗̉̋͆̿̊͘͜͜͝͝ͅͅͅt̵̡̨̜̘͎̦͚̠̗̺͉̼̠̲̠͙̺̹̗̲̏̈́̂̚͜͜͝ͅ"
# ------------------------
}
proc test_farmer {} {
proc test_farmer {} {
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
#get info about punk nestindex key ie type: list,dict,undetermined
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
}
proc invoke command {
proc invoke command {
@ -1127,17 +1112,35 @@ namespace eval punk::lib {
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
#get info about punk nestindex key ie type: list,dict,undetermined
# pdict devel
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
#???
}
#*** !doctools
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
}
}
tcl::namespace::eval punk::lib::debug {
proc showdict {args} {}
}
if {![info exists ::punk::args::register::NAMESPACES]} {
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
set codethread_cond [thread::cond create] ;#repl::codethread_cond held by parent(repl) vs punk::repl::codethread::replthread_cond held by child(codethread)
set codethread_cond [thread::cond create] ;#repl::codethread_cond held by parent(repl) vs punk::repl::codethread::replthread_cond held by child(codethread)
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_headerdefs [tcl::dict::create] ;#by header-row
set o_headerstates [tcl::dict::create]
set o_headerstates [tcl::dict::create]
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
}
}
tcl::dict::set result -values $header_row_items
tcl::dict::set result -values $header_row_items
#review - ensure always a headerdef record for each header?
if {[tcl::dict::exists $o_headerdefs $hidx]} {
set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]]
} else {
#warn for now
puts stderr "no headerdef record for header $hidx"
set opt_minh [tcl::dict::get $update_hdefs -minheight]
set opt_maxh [tcl::dict::get $update_hdefs -maxheight]
#todo - allow zero values to hide/collapse
# - see also configure_row
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
}
proc size2 {textblock} {
if {$textblock eq ""} {
return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack
if {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
set lines [split $textblock \n]
set num_le [expr {[llength $lines]-1}]
#set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]]
set width 0
foreach ln $lines {
set w [::punk::char::ansifreestring_width $ln]
if {$w > $width} {
set width $w
}
}
} else {
set num_le 0
set width [punk::char::ansifreestring_width $textblock]
}
#set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list
#our concept of block-height is likely to be different to other line-counting mechanisms
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size_as_opts {textblock} {
proc size_as_opts {textblock} {
set sz [size $textblock]
set sz [size $textblock]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
#Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
set str "Ẓ̌á̲l͔̝̞̄̑͌g̖̘̘̔̔͢͞͝o̪̔T̢̙̫̈̍͞e̬͈͕͌̏͑x̺̍ṭ̓̓ͅ"
}
proc test_zalgo2 {} {
# ------------------------
set str "Z̸̢͉̣͔̭̪͙̖̳̘͈͍̤̩̟͈͈͕̯̅̏̆̓̌́́͌̿̕ͅą̷̦̤̫̩͕̥̐̎̓́́̂̀͆́̔̄̈́̏̌́̆͜͜͝͠l̴̩̙̺͚̟͇͖͔͕̹̟͌̈́̄̇́̉̋̕̚͜͠͠g̸͇̩͔̺̝̗̥̖̙̑̈́̈́̿̾̌͌͊̈̀͊̑̇̑͌̍̅̌͊͜͠͝ǫ̴̢̧͎͔̞̤̻̱̮̬͕̗̭͍̣̠̳̆̀̋̓͒̾̄͜͝͠͝T̴̛͉̬̋́̈́̈́̓͗̍̏̔̈̋̀͐̓̎̅̚̕͠͝͝ê̵̖̖̈͊̔̓̔̐̓̃͊̋͋̎͂͋̕x̴̡͎͖̼͎̦͎̲̪̘̺̯̲̬̮̥̼̰͌̃͜ͅt̶̛̘͎̰̔͐͌́̈́͊͗͌̅͂̐̆͌̀͂͘"
# ------------------------
}
proc test_zalgo3 {} {
# ------------------------
set str "Ẕ̸̢̼̺̜̰̣̣̖̭̜͓͖̺̥̼̠͙͙̟̥̟̠̤̫͍̠̤̮͚̝̜̙͈̦̙̩̹̙̜̩̦͔͕̈̃̅̇̈́͂̇̽̈́́́́̎͊̂̑̋͆̔̾͋̚͜ͅã̵̛̪̽̎̃͑̒̇͋͂̽̃̍͊̀̈̊̊̔̊̆̈́͗͑͗̽̄̋͗̄͌̑͊͝͝͠ͅl̵̢͇̖͉͖̝̹̜̞͓͎͍͈̞̱̙͙̦̪͔̱̮͈͉̼͎̭̝̯͇͚̺̟̱͙̳̰̙͚͖̝̫͙̎̅̃͆̈́̋̌̔̋̋͗̈́̔̐͆̈́̓̾̄̀́̏́͒̆̌͒̈́̈́̾̏̀͜͝g̸̖͂͋̊͗̈́̓̆̈̋̒͐̕o̶̧̢͓̲̗̠̘͕̦̤̹̗͉̰͔̯͓̭̹̻͔͇̯̜̙̍̂̃̃̀̓͌̒͊̊̋̒̿̿̌͐̄͗̾̕͝T̶̛̳̜̰͍̹̻̫̠̱̼̼̙̆̑̾̾͛́́̿͋͌̎̀̀̽̆͌̽̂̈̇̅̇̃́̿͗̾͒̎͊̑̾͝͠ȩ̸̢̨̛̛̛̭͔͎͇̫͎͈̲̻̙͕͎̣͈̩̺̗͖͙͇͌͐̒̎͐̓́̉́͐̓̐͌̅̊͋͑̈́͗͑̏̕͜͜͝ͅx̸̧̧̛̖̣̥̘͎͎̳̭̙̦̝͖̝̮̱̹̯̺̙̩̯̮͖̻̰͓̰̩͇̥̑͌̊̐̉̏͆̓̑̎̊̓͒̂̄̆͆̀̊̄̈̽͐͛̏͊̓̌͑́̎̈́̍̈́̊͗̉̋͆̿̊͘͜͜͝͝ͅͅͅt̵̡̨̜̘͎̦͚̠̗̺͉̼̠̲̠͙̺̹̗̲̏̈́̂̚͜͜͝ͅ"
# ------------------------
}
proc test_farmer {} {
proc test_farmer {} {
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
#get info about punk nestindex key ie type: list,dict,undetermined
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
}
proc invoke command {
proc invoke command {
@ -1127,17 +1112,35 @@ namespace eval punk::lib {
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
#get info about punk nestindex key ie type: list,dict,undetermined
# pdict devel
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
#???
}
#*** !doctools
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
}
}
tcl::namespace::eval punk::lib::debug {
proc showdict {args} {}
}
if {![info exists ::punk::args::register::NAMESPACES]} {
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_headerdefs [tcl::dict::create] ;#by header-row
set o_headerstates [tcl::dict::create]
set o_headerstates [tcl::dict::create]
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
}
}
tcl::dict::set result -values $header_row_items
tcl::dict::set result -values $header_row_items
#review - ensure always a headerdef record for each header?
if {[tcl::dict::exists $o_headerdefs $hidx]} {
set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]]
} else {
#warn for now
puts stderr "no headerdef record for header $hidx"
set opt_minh [tcl::dict::get $update_hdefs -minheight]
set opt_maxh [tcl::dict::get $update_hdefs -maxheight]
#todo - allow zero values to hide/collapse
# - see also configure_row
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
}
proc size2 {textblock} {
if {$textblock eq ""} {
return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack
if {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
set lines [split $textblock \n]
set num_le [expr {[llength $lines]-1}]
#set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]]
set width 0
foreach ln $lines {
set w [::punk::char::ansifreestring_width $ln]
if {$w > $width} {
set width $w
}
}
} else {
set num_le 0
set width [punk::char::ansifreestring_width $textblock]
}
#set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list
#our concept of block-height is likely to be different to other line-counting mechanisms
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size_as_opts {textblock} {
proc size_as_opts {textblock} {
set sz [size $textblock]
set sz [size $textblock]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
#Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
set str "Ẓ̌á̲l͔̝̞̄̑͌g̖̘̘̔̔͢͞͝o̪̔T̢̙̫̈̍͞e̬͈͕͌̏͑x̺̍ṭ̓̓ͅ"
}
proc test_zalgo2 {} {
# ------------------------
set str "Z̸̢͉̣͔̭̪͙̖̳̘͈͍̤̩̟͈͈͕̯̅̏̆̓̌́́͌̿̕ͅą̷̦̤̫̩͕̥̐̎̓́́̂̀͆́̔̄̈́̏̌́̆͜͜͝͠l̴̩̙̺͚̟͇͖͔͕̹̟͌̈́̄̇́̉̋̕̚͜͠͠g̸͇̩͔̺̝̗̥̖̙̑̈́̈́̿̾̌͌͊̈̀͊̑̇̑͌̍̅̌͊͜͠͝ǫ̴̢̧͎͔̞̤̻̱̮̬͕̗̭͍̣̠̳̆̀̋̓͒̾̄͜͝͠͝T̴̛͉̬̋́̈́̈́̓͗̍̏̔̈̋̀͐̓̎̅̚̕͠͝͝ê̵̖̖̈͊̔̓̔̐̓̃͊̋͋̎͂͋̕x̴̡͎͖̼͎̦͎̲̪̘̺̯̲̬̮̥̼̰͌̃͜ͅt̶̛̘͎̰̔͐͌́̈́͊͗͌̅͂̐̆͌̀͂͘"
# ------------------------
}
proc test_zalgo3 {} {
# ------------------------
set str "Ẕ̸̢̼̺̜̰̣̣̖̭̜͓͖̺̥̼̠͙͙̟̥̟̠̤̫͍̠̤̮͚̝̜̙͈̦̙̩̹̙̜̩̦͔͕̈̃̅̇̈́͂̇̽̈́́́́̎͊̂̑̋͆̔̾͋̚͜ͅã̵̛̪̽̎̃͑̒̇͋͂̽̃̍͊̀̈̊̊̔̊̆̈́͗͑͗̽̄̋͗̄͌̑͊͝͝͠ͅl̵̢͇̖͉͖̝̹̜̞͓͎͍͈̞̱̙͙̦̪͔̱̮͈͉̼͎̭̝̯͇͚̺̟̱͙̳̰̙͚͖̝̫͙̎̅̃͆̈́̋̌̔̋̋͗̈́̔̐͆̈́̓̾̄̀́̏́͒̆̌͒̈́̈́̾̏̀͜͝g̸̖͂͋̊͗̈́̓̆̈̋̒͐̕o̶̧̢͓̲̗̠̘͕̦̤̹̗͉̰͔̯͓̭̹̻͔͇̯̜̙̍̂̃̃̀̓͌̒͊̊̋̒̿̿̌͐̄͗̾̕͝T̶̛̳̜̰͍̹̻̫̠̱̼̼̙̆̑̾̾͛́́̿͋͌̎̀̀̽̆͌̽̂̈̇̅̇̃́̿͗̾͒̎͊̑̾͝͠ȩ̸̢̨̛̛̛̭͔͎͇̫͎͈̲̻̙͕͎̣͈̩̺̗͖͙͇͌͐̒̎͐̓́̉́͐̓̐͌̅̊͋͑̈́͗͑̏̕͜͜͝ͅx̸̧̧̛̖̣̥̘͎͎̳̭̙̦̝͖̝̮̱̹̯̺̙̩̯̮͖̻̰͓̰̩͇̥̑͌̊̐̉̏͆̓̑̎̊̓͒̂̄̆͆̀̊̄̈̽͐͛̏͊̓̌͑́̎̈́̍̈́̊͗̉̋͆̿̊͘͜͜͝͝ͅͅͅt̵̡̨̜̘͎̦͚̠̗̺͉̼̠̲̠͙̺̹̗̲̏̈́̂̚͜͜͝ͅ"
# ------------------------
}
proc test_farmer {} {
proc test_farmer {} {
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
#get info about punk nestindex key ie type: list,dict,undetermined
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
}
proc invoke command {
proc invoke command {
@ -1127,17 +1112,35 @@ namespace eval punk::lib {
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
#get info about punk nestindex key ie type: list,dict,undetermined
# pdict devel
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
#???
}
#*** !doctools
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
}
}
tcl::namespace::eval punk::lib::debug {
proc showdict {args} {}
}
if {![info exists ::punk::args::register::NAMESPACES]} {
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_headerdefs [tcl::dict::create] ;#by header-row
set o_headerstates [tcl::dict::create]
set o_headerstates [tcl::dict::create]
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
}
}
tcl::dict::set result -values $header_row_items
tcl::dict::set result -values $header_row_items
#review - ensure always a headerdef record for each header?
if {[tcl::dict::exists $o_headerdefs $hidx]} {
set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]]
} else {
#warn for now
puts stderr "no headerdef record for header $hidx"
set opt_minh [tcl::dict::get $update_hdefs -minheight]
set opt_maxh [tcl::dict::get $update_hdefs -maxheight]
#todo - allow zero values to hide/collapse
# - see also configure_row
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
}
proc size2 {textblock} {
if {$textblock eq ""} {
return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack
if {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
set lines [split $textblock \n]
set num_le [expr {[llength $lines]-1}]
#set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]]
set width 0
foreach ln $lines {
set w [::punk::char::ansifreestring_width $ln]
if {$w > $width} {
set width $w
}
}
} else {
set num_le 0
set width [punk::char::ansifreestring_width $textblock]
}
#set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list
#our concept of block-height is likely to be different to other line-counting mechanisms
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size_as_opts {textblock} {
proc size_as_opts {textblock} {
set sz [size $textblock]
set sz [size $textblock]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
#Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
set str "Ẓ̌á̲l͔̝̞̄̑͌g̖̘̘̔̔͢͞͝o̪̔T̢̙̫̈̍͞e̬͈͕͌̏͑x̺̍ṭ̓̓ͅ"
}
proc test_zalgo2 {} {
# ------------------------
set str "Z̸̢͉̣͔̭̪͙̖̳̘͈͍̤̩̟͈͈͕̯̅̏̆̓̌́́͌̿̕ͅą̷̦̤̫̩͕̥̐̎̓́́̂̀͆́̔̄̈́̏̌́̆͜͜͝͠l̴̩̙̺͚̟͇͖͔͕̹̟͌̈́̄̇́̉̋̕̚͜͠͠g̸͇̩͔̺̝̗̥̖̙̑̈́̈́̿̾̌͌͊̈̀͊̑̇̑͌̍̅̌͊͜͠͝ǫ̴̢̧͎͔̞̤̻̱̮̬͕̗̭͍̣̠̳̆̀̋̓͒̾̄͜͝͠͝T̴̛͉̬̋́̈́̈́̓͗̍̏̔̈̋̀͐̓̎̅̚̕͠͝͝ê̵̖̖̈͊̔̓̔̐̓̃͊̋͋̎͂͋̕x̴̡͎͖̼͎̦͎̲̪̘̺̯̲̬̮̥̼̰͌̃͜ͅt̶̛̘͎̰̔͐͌́̈́͊͗͌̅͂̐̆͌̀͂͘"
# ------------------------
}
proc test_zalgo3 {} {
# ------------------------
set str "Ẕ̸̢̼̺̜̰̣̣̖̭̜͓͖̺̥̼̠͙͙̟̥̟̠̤̫͍̠̤̮͚̝̜̙͈̦̙̩̹̙̜̩̦͔͕̈̃̅̇̈́͂̇̽̈́́́́̎͊̂̑̋͆̔̾͋̚͜ͅã̵̛̪̽̎̃͑̒̇͋͂̽̃̍͊̀̈̊̊̔̊̆̈́͗͑͗̽̄̋͗̄͌̑͊͝͝͠ͅl̵̢͇̖͉͖̝̹̜̞͓͎͍͈̞̱̙͙̦̪͔̱̮͈͉̼͎̭̝̯͇͚̺̟̱͙̳̰̙͚͖̝̫͙̎̅̃͆̈́̋̌̔̋̋͗̈́̔̐͆̈́̓̾̄̀́̏́͒̆̌͒̈́̈́̾̏̀͜͝g̸̖͂͋̊͗̈́̓̆̈̋̒͐̕o̶̧̢͓̲̗̠̘͕̦̤̹̗͉̰͔̯͓̭̹̻͔͇̯̜̙̍̂̃̃̀̓͌̒͊̊̋̒̿̿̌͐̄͗̾̕͝T̶̛̳̜̰͍̹̻̫̠̱̼̼̙̆̑̾̾͛́́̿͋͌̎̀̀̽̆͌̽̂̈̇̅̇̃́̿͗̾͒̎͊̑̾͝͠ȩ̸̢̨̛̛̛̭͔͎͇̫͎͈̲̻̙͕͎̣͈̩̺̗͖͙͇͌͐̒̎͐̓́̉́͐̓̐͌̅̊͋͑̈́͗͑̏̕͜͜͝ͅx̸̧̧̛̖̣̥̘͎͎̳̭̙̦̝͖̝̮̱̹̯̺̙̩̯̮͖̻̰͓̰̩͇̥̑͌̊̐̉̏͆̓̑̎̊̓͒̂̄̆͆̀̊̄̈̽͐͛̏͊̓̌͑́̎̈́̍̈́̊͗̉̋͆̿̊͘͜͜͝͝ͅͅͅt̵̡̨̜̘͎̦͚̠̗̺͉̼̠̲̠͙̺̹̗̲̏̈́̂̚͜͜͝ͅ"
# ------------------------
}
proc test_farmer {} {
proc test_farmer {} {
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
#get info about punk nestindex key ie type: list,dict,undetermined
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
}
proc invoke command {
proc invoke command {
@ -1127,17 +1112,35 @@ namespace eval punk::lib {
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
#get info about punk nestindex key ie type: list,dict,undetermined
# pdict devel
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
#???
}
#*** !doctools
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
}
}
tcl::namespace::eval punk::lib::debug {
proc showdict {args} {}
}
if {![info exists ::punk::args::register::NAMESPACES]} {
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
set codethread_cond [thread::cond create] ;#repl::codethread_cond held by parent(repl) vs punk::repl::codethread::replthread_cond held by child(codethread)
set codethread_cond [thread::cond create] ;#repl::codethread_cond held by parent(repl) vs punk::repl::codethread::replthread_cond held by child(codethread)
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_headerdefs [tcl::dict::create] ;#by header-row
set o_headerstates [tcl::dict::create]
set o_headerstates [tcl::dict::create]
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
}
}
tcl::dict::set result -values $header_row_items
tcl::dict::set result -values $header_row_items
#review - ensure always a headerdef record for each header?
if {[tcl::dict::exists $o_headerdefs $hidx]} {
set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]]
} else {
#warn for now
puts stderr "no headerdef record for header $hidx"
set opt_minh [tcl::dict::get $update_hdefs -minheight]
set opt_maxh [tcl::dict::get $update_hdefs -maxheight]
#todo - allow zero values to hide/collapse
# - see also configure_row
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
}
proc size2 {textblock} {
if {$textblock eq ""} {
return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack
if {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
set lines [split $textblock \n]
set num_le [expr {[llength $lines]-1}]
#set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]]
set width 0
foreach ln $lines {
set w [::punk::char::ansifreestring_width $ln]
if {$w > $width} {
set width $w
}
}
} else {
set num_le 0
set width [punk::char::ansifreestring_width $textblock]
}
#set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list
#our concept of block-height is likely to be different to other line-counting mechanisms
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size_as_opts {textblock} {
proc size_as_opts {textblock} {
set sz [size $textblock]
set sz [size $textblock]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]
