package require overtype ;# circular dependency - many components require overtype. Here we only need it for nice layout in the a? query proc - so we'll do a soft-dependency by only loading when needed and also wrapping in a try
package require overtype ;# circular dependency - many components require overtype. Here we only need it for nice layout in the a? query proc - so we'll do a soft-dependency by only loading when needed and also wrapping in a try
package require textblock
package require textblock
append out [textblock::join $indent [tcl::string::map $strmap $settings_applied]] \n
append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n
append out [textblock::join $indent [tcl::string::trim $SGR_colour_map \n]] \n
append out [textblock::join -- $indent [tcl::string::trim $SGR_colour_map \n]] \n
append out [textblock::join $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n
append out [textblock::join -- $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n
set bgname "Web-white"
set bgname "Web-white"
set map1 [colourmap1 -bg $bgname -forcecolour $opt_forcecolour]
set map1 [colourmap1 -bg $bgname -forcecolour $opt_forcecolour]
set map1 [overtype::centre -transparent 1 $map1 "[a {*}$fc black $bgname]Standard colours[a]"]
set map1 [overtype::centre -transparent 1 $map1 "[a {*}$fc black $bgname]Standard colours[a]"]
set map2 [colourmap2 -bg $bgname -forcecolour $opt_forcecolour]
set map2 [colourmap2 -bg $bgname -forcecolour $opt_forcecolour]
set map2 [overtype::centre -transparent 1 $map2 "[a {*}$fc black $bgname]High-intensity colours[a]"]
set map2 [overtype::centre -transparent 1 $map2 "[a {*}$fc black $bgname]High-intensity colours[a]"]
append out [textblock::join $indent [textblock::join -- $map1 $map2]] \n
append out [textblock::join -- $indent [textblock::join -- $map1 $map2]] \n
append out "[a+ {*}$fc web-white]216 colours of 256 terminal colours (To see names, use: a? term ?pastel? ?rainbow?)[a]" \n
append out "[a+ {*}$fc web-white]216 colours of 256 terminal colours (To see names, use: a? term ?pastel? ?rainbow?)[a]" \n
append out [textblock::join $indent [colourblock_216 -forcecolour $opt_forcecolour]] \n
append out [textblock::join -- $indent [colourblock_216 -forcecolour $opt_forcecolour]] \n
append out "[a+ {*}$fc web-white]24 Greyscale colours[a]" \n
append out "[a+ {*}$fc web-white]24 Greyscale colours[a]" \n
append out [textblock::join $indent [colourblock_24 -forcecolour $opt_forcecolour]] \n
append out [textblock::join -- $indent [colourblock_24 -forcecolour $opt_forcecolour]] \n
append out [textblock::join $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n
append out [textblock::join -- $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n
append out \n
append out \n
append out "[a+ {*}$fc web-white]Web colours[a]" \n
append out "[a+ {*}$fc web-white]Web colours[a]" \n
append out [textblock::join $indent "To see all names use: a? web"] \n
append out [textblock::join -- $indent "To see all names use: a? web"] \n
append out [textblock::join $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n
append out [textblock::join -- $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n
append out [textblock::join $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n
append out [textblock::join -- $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n
#todo - a version of get_dict that supports punk::lib::tstr templating
#rename get_dict
#provide ability to look up and reuse definitions from ids etc
#
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values
#If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags.
#If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags.
#this would be important in the case where the function to be wrapped has never been called - but the wrapper needs info about the downstream options
#this would be important in the case where the function to be wrapped has never been called - but the wrapper needs info about the downstream options
#we would like to avoid the ugliness of trying to parse a proc body to scrape the specification.
#we would like to avoid the ugliness of trying to parse a proc body to scrape the specification.
#we may still need to do a basic scan of the proc body to determine if it at least contains the string punk::args::get_dict - but that is slightly less odious.
#we may still need to do a basic scan of the proc body to determine if it at least contains the string punk::args::get_dict - but that is slightly less odious.
error "unsupported"
error "unsupported number of arguments for punk::args::get_dict"
#[para]The encoding used is as specified in the -encoding option - or from the Byte Order Mark (bom) at the beginning of the data
#[para]The encoding used is as specified in the -encoding option - or from the Byte Order Mark (bom) at the beginning of the data
#[para]For Tcl 8.6 - encodings such as utf-16le may not be available - so the bytes are swapped appropriately depending on the platform byteOrder and encoding 'unicode' is used.
#[para]For Tcl 8.6 - encodings such as utf-16le may not be available - so the bytes are swapped appropriately depending on the platform byteOrder and encoding 'unicode' is used.
#[para]encoding defaults to utf-8 if no -encoding specified and no BOM was found
#[para]encoding defaults to utf-8 if no -encoding specified and no BOM was found
#[para]Specify -encoding binary to perform no encoding conversion
#[para]Whether -encoding was specified or not - by default the BOM characters are not retained in the line-data
#[para]Whether -encoding was specified or not - by default the BOM characters are not retained in the line-data
#[para]If -includebom 1 is specified - the bom will be retained in the stored chunk and the data for line 1, but will undergo the same encoding transformation as the rest of the data
#[para]If -includebom 1 is specified - the bom will be retained in the stored chunk and the data for line 1, but will undergo the same encoding transformation as the rest of the data
#[para]The get_bomid method of the returned object will contain an identifier for any BOM encountered.
#[para]The get_bomid method of the returned object will contain an identifier for any BOM encountered.
#[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes (binary translation)
#[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes of whatever encoding that is.
#[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data.
#[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data.
#[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding binary if this isn't suitable and you need to do your own processing of the raw data.
#[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes.
lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart]
incr start
if {$start >= [tcl::string::length $text]} {
break
}
continue
}
lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1]
set start [expr {$matchEnd+1}]
#?
if {$start >= [tcl::string::length $text]} {
break
}
}
return [lappend list [tcl::string::range $text $start end]]
}
#get info about punk nestindex key ie type: list,dict,undetermined
proc nestindex_info {args} {
set argd [punk::args::get_dict {
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 pdict {args} {
set sep " [a+ Web-seagreen]=[a] "
set argspec [string map [list %sep% $sep] {
*proc -name pdict -help {Print dict keys,values to channel
*proc -name pdict -help {Print dict keys,values to channel
(see also showdict)}
(see also showdict)}
*opts -any 1
*opts -any 1
#default separator to provide similarity to tcl's parray function
#default separator to provide similarity to tcl's parray function
-separator -default " = "
-separator -default "%sep%"
-roottype -default "dict"
-substructure -default {}
-channel -default stdout -help "existing channel - or 'none' to return as string"
-channel -default stdout -help "existing channel - or 'none' to return as string"
*values -min 1 -max -1
*values -min 1 -max -1
dictvar -type string -help "name of dict variable"
dictvar -type string -help "name of dict variable"
patterns -type string -default * -multiple 1
patterns -type string -default "*" -multiple 1
} $args]
}]
#puts stderr "$argspec"
set argd [punk::args::get_dict $argspec $args]
set opts [dict get $argd opts]
set opts [dict get $argd opts]
set dvar [dict get $argd values dictvar]
set dvar [dict get $argd values dictvar]
set patterns [dict get $argd values patterns]
set patterns [dict get $argd values patterns]
set isarray [uplevel 1 [list array exists $dvar]]
if {$isarray} {
set dvalue [uplevel 1 [list array get $dvar]]
dict set opts -keytemplates [list ${dvar}(%k%)]
dict set opts -keysorttype dictionary
} else {
set dvalue [uplevel 1 [list set $dvar]]
set dvalue [uplevel 1 [list set $dvar]]
}
showdict {*}$opts $dvalue {*}$patterns
showdict {*}$opts $dvalue {*}$patterns
}
}
#TODO - much.
#showdict needs to be able to show different branches which share a root path
#e.g show key a1/b* in its entirety along with a1/c* - (or even exact duplicates)
# - specify ansi colour per pattern so different branches can be highlighted?
# - ideally we want to be able to use all the dict & list patterns from the punk pipeline system eg @head @tail # (count) etc
# - The current version is incomplete but passably usable.
# - Copy proc and attempt rework so we can get back to this as a baseline for functionality
proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value)
proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value)
set argd [punk::args::get_dict {
set sep " [a+ Web-seagreen]=[a] "
set argd [punk::args::get_dict [string map [list %sep% $sep] {
*id punk::lib::pdict
*id punk::lib::pdict
*proc -name punk::lib::pdict -help "display dictionary keys and values"
*proc -name punk::lib::pdict -help "display dictionary keys and values"
#todo - table tableobject
#todo - table tableobject
@ -423,77 +626,333 @@ namespace eval punk::lib {
-trimright -default 1 -type boolean -help "Trim whitespace off rhs of each line.
-trimright -default 1 -type boolean -help "Trim whitespace off rhs of each line.
This can help prevent a single long line that wraps in terminal from making every line wrap due to long rhs padding
This can help prevent a single long line that wraps in terminal from making every line wrap due to long rhs padding
"
"
-separator -default " " -help "Separator column between keys and values"
-separator -default "%sep%" -help "Separator column between keys and values"
-ansibase_keys -default ""
-roottype -default "" -help "list,dict,string"
-substructure -default {}
-ansibase_keys -default "" -help "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]"
-ansibase_values -default ""
-ansibase_values -default ""
-keytemplates -default {%k%} -type list -help "list of templates for keys at each level"
# #we can only get duplicate keys if there are multiple patterns supplied
# #ignore keysortdirection - doesn't apply
# if {[llength $patterns] > 1} {
# #order-maintaining (order of keys as they appear in dict)
# set filtered_keys [punk::lib::lunique $filtered_keys]
# }
#} else {
# set filtered_keys [lsort -unique -$opt_keysorttype -$opt_keysortdirection $filtered_keys]
#}
} else {
#string
puts stdout "xxxx string"
return $dval
}
}
if {[llength $filtered_keys]} {
if {[llength $filtered_keys]} {
#both keys and values could have newline characters.
#both keys and values could have newline characters.
#simple use of 'format' won't cut it for more complex dict keys/values
#simple use of 'format' won't cut it for more complex dict keys/values
#use block::width or our columns won't align in some cases
#use block::width or our columns won't align in some cases
set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]]
set RST [a]
set RST [a]
switch -- $opt_return {
switch -- $opt_return {
"tailtohead" {
"tailtohead" {
#last line of key is side by side (possibly with separator) with first line of value
#last line of key is side by side (possibly with separator) with first line of value
#This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values
#This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values
#we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries
#we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries
#todo - slower lsearch if -dupes 1 flag set so we can display duplicate 'keys' if var not a proper dict but rather a dict-shaped list that we want to display as a dict
# - default highlight dupes (ansi underline?)
set thisval [tcl::dict::get $dval $key]
}
if {$opt_roottype eq "dict"} {
#set substructure [lrange $opt_structure 1 end]
set nextpatterns [list]
set pattern_nest [lindex $pattern_key_index $kidx]
set nextsub [dict get $pattern_next_substructure $pattern_nest]
#which pattern nest applies to this branch
set pattern_nest_list [split $pattern_nest /]
if {[llength $pattern_nest_list]} {
set tail [lassign $pattern_nest_list parent]
set nest $tail
#if {![llength $tail]} {
# set nest *
#}
lappend nextpatterns [join $nest /]
}
#puts "k:$key dict nextpatterns: $nextpatterns"
set subansibasekeys [lrange $opt_ansibase_keys 1 end]
set nextkeytemplates [lrange $opt_keytemplates 1 end]
set blanks_above [string repeat \n [expr {$kheight -1}]]
set blanks_above [string repeat \n [expr {$kheight -1}]]
set blanks_below [string repeat \n [expr {$vheight -1}]]
set blanks_below [string repeat \n [expr {$vheight -1}]]
set sepwidth [textblock::width $opt_sep]
set sepwidth [textblock::width $opt_sep]
#append result [textblock::pad $opt_ansibase_key$key$RST -width $maxl] $opt_sep $opt_ansibase_value[dict get $dval $key]$RST \n
set kblock [textblock::pad $ansibase_key$keydisplay$RST$blanks_below -width $maxl]
set kblock [textblock::pad $opt_ansibase_key$key$RST$blanks_below -width $maxl]
set sblock [textblock::pad $blanks_above$opt_sep$blanks_below -width $sepwidth]
set sblock [textblock::pad $blanks_above$opt_sep$blanks_below -width $sepwidth]
set vblock $blanks_above$opt_ansibase_value[dict get $dval $key]$RST
set vblock $blanks_above$opt_ansibase_values$thisval$RST
#only vblock is ragged - we can do a basic join because we don't care about rhs whitespace
#only vblock is ragged - we can do a basic join because we don't care about rhs whitespace
append result [textblock::join_basic $kblock $sblock $vblock] \n
append result [textblock::join_basic -- $kblock $sblock $vblock] \n
incr kidx
}
}
}
}
"sidebyside" {
"sidebyside" {
#This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs.
#This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs.
#use ansibase_key etc to make the output more comprehensible in that situation.
#use ansibase_key etc to make the output more comprehensible in that situation.
#This is why it is not the default. (review - terminal width detection and wrapping?)
#This is why it is not the default. (review - terminal width detection and wrapping?)
set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]]
foreach key $filtered_keys {
foreach key $filtered_keys {
set kt [lindex $opt_keytemplates 0]
if {$kt eq ""} {
set kt "%k%"
}
set keydisplay $opt_ansibase_keys[string map [list %k% $key] $kt]$RST
#append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n
#append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n
#differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic
#differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic
append result [textblock::join -- [textblock::pad $opt_ansibase_key$key$RST -width $maxl] $opt_sep "$opt_ansibase_value[dict get $dval $key]$RST"] \n
append result [textblock::join -- [textblock::pad $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n
}
}
}
}
}
}
@ -765,19 +1224,23 @@ namespace eval punk::lib {
#[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 -1 if the supplied index expression is out of bounds for the supplied list.
#[para]lindex_resolve will parse the index expression and return:
#[para] a) -2 if the supplied index expression is below the lower bound for the supplied list. (< 0)
#[para] b) -1 if the supplied index expression is above the upper bound for the supplied list. (> end)
#[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 or 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
#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 we will resolve (hopefully safely) with expr
#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 we will resolve (hopefully safely) with expr
if {![llength $list]} {
#if {![llength $list]} {
return -1
# #review
}
# return ???
#}
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 -1
return -2
} elseif {$index >= [llength $list]} {
} elseif {$index >= [llength $list]} {
return -1
return -1
} else {
} else {
@ -794,16 +1257,28 @@ namespace eval punk::lib {
return -1
return -1
}
}
} else {
} else {
set offset 0
#end
set index [expr {[llength $list]-1}]
if {$index < 0} {
#special case - end with empty list - treat end like a positive number out of bounds
return -1
} else {
return $index
}
}
}
#by now, if op = + then offset = 0 so we only need to handle the minus case
if {$offset == 0} {
if {$offset == 0} {
set index [expr {[llength $list]-1}]
set index [expr {[llength $list]-1}]
if {$index < 0} {
return -1 ;#special case
} else {
return $index
}
} else {
} else {
#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 {([llength $list]-1) - $offset}]
}
}
if {$index < 0} {
if {$index < 0} {
return -1
return -2
} else {
} else {
return $index
return $index
}
}
@ -823,15 +1298,24 @@ namespace eval punk::lib {
} else {
} else {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
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+ but that's likely unavailable here.
#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+ but that's likely unavailable here.
for {set i 0} {$i < [llength $list]} {incr i} {
#for {set i 0} {$i < [llength $list]} {incr i} {
lappend indices $i
# lappend indices $i
#}
if {[llength $list]} {
set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback.
error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'all' or a positive integer"
error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'any' or a positive integer"
}
}
} else {
} else {
if {$s ne "all" && $s ne ""} {
if {$s ne "any" && $s ne ""} {
error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'all'"
error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'"
}
}
}
}
} else {
} else {
#if {![tcl::string::is integer -strict $s]} {
#if {![tcl::string::is integer -strict $s]} {
# if {$s ne "all" && $s ne ""} {
# if {$s ne "any" && $s ne ""} {
# error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'all'"
# error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'"
# }
# }
#} else {
#} else {
set header_spans [tcl::dict::get $cspans $h]
set header_spans [tcl::dict::get $cspans $h]
set remaining [lindex $header_spans 0]
set remaining [lindex $header_spans 0]
if {$remaining ne "all"} {
if {$remaining ne "any"} {
incr remaining -1
incr remaining -1
}
}
#look at spans defined for previous cols
#look at spans defined for previous cols
#we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption
#we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption
set downbox [textblock::framedef $ftype_header -joins {down}]
tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype
tcl::dict::set this_span_map blc [tcl::dict::get $downbox hlbj] ;#horizontal line bottom with down join - to same frametype
}
}
} else {
} else {
#join to body
#join to body
set downbox [textblock::framedef $ftype_header -joins [list down-$fname_body]]
tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype
tcl::dict::set this_span_map blc [tcl::dict::get $downbox hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype
#spanned values default left - todo make configurable
#spanned values default left - todo make configurable
#TODO
#consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span
#we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes?
#this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span.
#(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned)
#when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1)
#we need to shift 1 to the left when doing our overtype with blockalign right
#we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge
#(even though the column position may be left or inner)
#we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric
set all_colspans [my header_colspans_numeric]
#JMN
#store configured widths so we don't look up for each header line
#store configured widths so we don't look up for each header line
set configured_widths [list]
#set configured_widths [list]
foreach c [tcl::dict::keys $o_columndefs] {
#foreach c [tcl::dict::keys $o_columndefs] {
#lappend configured_widths [my column_width $c]
# #lappend configured_widths [my column_width $c]
#we don't just want the width of the column in the body - or the headers will get truncated
# #we don't just want the width of the column in the body - or the headers will get truncated
set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span] ;#widest of headers in this col with same span - allows textalign to work with blockalign
set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign
set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth]
set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth]
set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank]
set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank]
$t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs)
return $t
}
#more complex colspans
#more complex colspans
proc spantest2 {} {
proc spantest2 {} {
set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}]
set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}]
#here we avoid the punk::args usage on the happy path, even though punk::args is fairly fast, in favour of an even faster literal switch on the happy path
#this means we have some duplication in where our flags/opts are defined: here in opts, and in spec below to give nicer error output without affecting performance.
#It also means we can't specify checks on the option types etc
set opts [tcl::dict::create\
set opts [tcl::dict::create\
-joins ""\
-joins ""\
-boxonly 0\
-boxonly 0\
]
]
foreach {k v} $args {
set bad_option 0
foreach {k v} $argopts {
switch -- $k {
switch -- $k {
-joins - -boxonly {
-joins - -boxonly {
tcl::dict::set opts $k $v
tcl::dict::set opts $k $v
}
}
default {
default {
error "framedef unknown option '$k'. Known options [tcl::dict::keys $opts]"
set bad_option
break
}
}
}
}
}
if {[llength $args] % 2 == 0 || $bad_option} {
#no framedef supplied, or unrecognised opt seen
set spec [string map [list <ftlist> $::textblock::frametypes] {
*proc -name textblock::framedef
-joins -default "" -help "List of join directions, any of: up down left right
or those combined with another frametype e.g left-heavy down-light"
-boxonly -default 0 -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"
*values -min 1 -max 1
frametype -help "name from the predefined frametypes:<ftlist>
set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing
set custom_frame [tcl::dict::merge $default_custom $f]
if {[llength $f] % 2 != 0} {
tcl::dict::with custom_frame {} ;#extract keys as vars
#todo - retrieve usage from punk::args
error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $textblock::frametypes and does not appear to be a dictionary for a custom frametype"
if {[tcl::dict::exists $custom_frame hlt]} {
set hlt [tcl::dict::get $custom_frame hlt]
} else {
set hlt $hl
}
}
if {[tcl::dict::exists $custom_frame hlb]} {
#unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults
