set stepindent [expr {$this_indent - $rootindent}]
dict set indents_seen $this_indent 1
} elseif {$this_indent < $rootindent} {
error "bad root indentation ($this_indent) at line: $linenum. Smallest indent was set on linenumber: $firstkey_linenum by first key line: $firstkey_line"
}
#if equal - it's just another root key
} else {
if {$stepindent < 0} {
set stepindent $this_indent
set firststepline $ln
#validate all others
if {$this_indent < $rootindent} {
error "bad root indentation ($this_indent) at line: $linenum. Smallest indent was set on linenumber: $firstkey_linenum by first key line: $firstkey_line"
}
if {$this_indent == $stepindent} {
dict set d [lindex $keys end] $ln
if {($this_indent - $rootindent) % $stepindent != 0} {
error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. this_indent - rootindent ($this_indent - $rootindent == [expr {$this_indent - $rootindent}]) is not a multiple of the first key indent $stepindent seen on linenumber: $firststep_linenum value:'$firststep_line'"
} else {
if {($this_indent % $stepindent) != 0} {
error "bad indentation ($this_indent) at line: $i not a multiple of the first key indent $step_indent seen on $firststepline"
set arg_error_CLR(testsinglecolour) [a+ yellow] ;#A single SGR colour to test current colour on|off state (empty string vs some result - used to determine if forcereload required)
#refresh ifneeded scripts for just_added/just_changed
#review: searchpaths are in auto_path order - earliest has precedence for any particular pkg-version
#REVIEW: what is to stop an auto_path package e.g from os, overriding a .tm ifneeded script from an item earlier in the package_mode list configured in punk's main.tcl?
#e.g when package_mode is {dev-os} we don't want a pkgIndex package from ::env(TCLLIBPATH) overriding a .tm from the dev paths (even if version nums the same)
#conversely we do want a dev path pkIndex package overriding an existing ifneeded script from a .tm in os
#to accomodate this - we may need to maintain a subdict in epoch of paths/path-prefixes to package_mode members os, dev, internal
#this 'refresh' is really a 'reversion' to what was already stored in epoch pkg epochs <currente> added
#
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
set ordered_searchpaths [lreverse [dict keys $dict_added]];# ordered as in auto_path
set stepindent [expr {$this_indent - $rootindent}]
dict set indents_seen $this_indent 1
} elseif {$this_indent < $rootindent} {
error "bad root indentation ($this_indent) at line: $linenum. Smallest indent was set on linenumber: $firstkey_linenum by first key line: $firstkey_line"
}
#if equal - it's just another root key
} else {
if {$stepindent < 0} {
set stepindent $this_indent
set firststepline $ln
#validate all others
if {$this_indent < $rootindent} {
error "bad root indentation ($this_indent) at line: $linenum. Smallest indent was set on linenumber: $firstkey_linenum by first key line: $firstkey_line"
}
if {$this_indent == $stepindent} {
dict set d [lindex $keys end] $ln
if {($this_indent - $rootindent) % $stepindent != 0} {
error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. this_indent - rootindent ($this_indent - $rootindent == [expr {$this_indent - $rootindent}]) is not a multiple of the first key indent $stepindent seen on linenumber: $firststep_linenum value:'$firststep_line'"
} else {
if {($this_indent % $stepindent) != 0} {
error "bad indentation ($this_indent) at line: $i not a multiple of the first key indent $step_indent seen on $firststepline"
#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
#(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
#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 ""
switch -- $a_index {
-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 z_index [lindex_resolve $l $z]
set z_index [lindex_resolve $len $z]
set z_msg ""
switch -- $z_index {
-2 {
@ -1146,7 +1147,7 @@ namespace eval punk::lib {
- then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator.
e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1
Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent
The second level segement in each pattern switches to a dict operation to retrieve the value by key.
The second level segment in each pattern switches to a dict operation to retrieve the value by key.
When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level.
}
}]
@ -1514,7 +1515,7 @@ namespace eval punk::lib {
if {![regexp $re_idxdashidx $p _match a b]} {
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
if {${lower_resolve} == -2} {
##x
@ -1527,7 +1528,7 @@ namespace eval punk::lib {
} else {
set lower $lower_resolve
}
set upper [punk::lib::lindex_resolve $dval $b]
set upper [punk::lib::lindex_resolve [llength $dval] $b]
if {$upper == -3} {
##x
#upper bound is below list range -
@ -1880,7 +1881,8 @@ namespace eval punk::lib {
if {$last_hidekey} {
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
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 {
@id -id ::punk::lib::lindex_resolve
@cmd -name punk::lib::lindex_resolve\
-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\
"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, or to a negative value below -1 indicating
whether the index was below or above the range of possible indices for the list.
"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/string length, or to a negative value below -1 indicating
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
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)
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
out of range at either end of the list
Otherwise it will return an integer corresponding to the position in the list.
This is in stark contrast to Tcl list function indices which will return empty strings for out of
out of range at either end of the list/string.
Otherwise it will return an integer corresponding to the position in the data.
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.
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
Like Tcl list commands - it will produce an error if the form of the index is not acceptable.
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
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
#[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/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]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]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] 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]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
@ -2298,12 +2301,16 @@ namespace eval punk::lib {
# #review
# 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
if {[string is integer -strict $index]} {
#can match +i -i
if {$index < 0} {
return -3
} elseif {$index >= [llength $list]} {
} elseif {$index >= $len} {
return -2
} else {
#integer may still have + sign - normalize with expr
@ -2320,7 +2327,7 @@ namespace eval punk::lib {
}
} else {
#index is 'end'
set index [expr {[llength $list]-1}]
set index [expr {$len-1}]
if {$index < 0} {
#special case - 'end' with empty list - treat end like a positive number out of bounds
return -2
@ -2329,7 +2336,7 @@ namespace eval punk::lib {
}
}
if {$offset == 0} {
set index [expr {[llength $list]-1}]
set index [expr {$len-1}]
if {$index < 0} {
return -2 ;#special case as above
} else {
@ -2337,7 +2344,7 @@ namespace eval punk::lib {
}
} else {
#by now, if op = + then offset = 0 so we only need to handle the minus case
#[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] 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] 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+
# - which
#for {set i 0} {$i < [llength $list]} {incr i} {
# lappend indices $i
#}
if {![string is integer -strict $len]} {
error "lindex_resolve_basic len must be an integer"
}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
#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.
return -1
} else {
@ -2396,13 +2402,15 @@ namespace eval punk::lib {
return [expr {$index}]
}
}
if {[llength $list]} {
set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback.
#if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?)
if {$len > 0} {
#For large len - this is a wasteful allocation if no true lseq available in Tcl version.
#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 {
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 ""} {
#we have no way to determine if out of bounds is at lower vs upper end
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]
#refresh ifneeded scripts for just_added/just_changed
#review: searchpaths are in auto_path order - earliest has precedence for any particular pkg-version
#REVIEW: what is to stop an auto_path package e.g from os, overriding a .tm ifneeded script from an item earlier in the package_mode list configured in punk's main.tcl?
#e.g when package_mode is {dev-os} we don't want a pkgIndex package from ::env(TCLLIBPATH) overriding a .tm from the dev paths (even if version nums the same)
#conversely we do want a dev path pkIndex package overriding an existing ifneeded script from a .tm in os
#to accomodate this - we may need to maintain a subdict in epoch of paths/path-prefixes to package_mode members os, dev, internal
#this 'refresh' is really a 'reversion' to what was already stored in epoch pkg epochs <currente> added
#
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]];# ordered 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]
#todo - find the iscript in the '$epoch pkg epochs <e> added paths' lists and determine os vs dev vs internal
#(scanning for path directly in the ifneeded script for pkgs is potentially error prone)
#for .tm ifneeded scripts - the syntax is simple enough to determine directly (and ifneeded scr not stored for those anyway)
if {[package ifneeded $pkg $v] ne $iscript} {
#puts "---->refreshing $pkg $v - reverting to already stored from path:$searchpath"
set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg]
if {[llength $pkgloadedinfo]} {
puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available"
lassign $pkgloadedinfo path name
set lcpath [string tolower $path]
if {[llength $available_versions] > 1} {
puts stderr "--> pkg $pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and [llength $available_versions] versions available"
}
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.
#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]]
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 {$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
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
if {[tcl::dict::exists $pad_cache $missing]} {
set pad [tcl::dict::get $pad_cache $missing]
#padchar may be more than 1 wide - because of 2wide unicode and or multiple chars
if {[tcl::dict::exists $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 {
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 {
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
set base [tcl::string::repeat " " $missing]
set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]]
}
switch -- $which-$opt_withinansi {
r-0 {
lappend line_chunks $pad
}
r-1 {
if {[lindex $line_chunks end] eq ""} {
set line_chunks [linsert $line_chunks end-2 $pad]
} else {
lappend line_chunks $pad
}
}
r-2 {
dict set pad_cache $missing $pad
}
switch -- $which-$opt_withinansi {
r-0 {
lappend line_chunks $pad
}
r-1 {
if {[lindex $line_chunks end] eq ""} {
set line_chunks [linsert $line_chunks end-2 $pad]
} else {
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 ""} {
set line_chunks [linsert $line_chunks 2 $pad]
} else {
set line_chunks [linsert $line_chunks 0 $pad]
}
}
l-2 {
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]
}
} 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 {
#we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes
lappend line_chunks ""
#deal with last part zzz of xxx\nyyy\nzzz - not yet a complete line
set pl [lindex $partlines end]
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 "")} {
#- 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.
