Browse Source

misc ansi fixes, refactoring

master
Julian Noble 2 months ago
parent
commit
d814e7e283
  1. 148
      src/bootsupport/modules/dictn-0.1.2.tm
  2. 241
      src/bootsupport/modules/punk/lib-0.1.5.tm
  3. 3
      src/bootsupport/modules/punk/repl-0.1.2.tm
  4. 18
      src/bootsupport/modules/punkcheck-0.1.0.tm
  5. 32
      src/bootsupport/modules/textblock-0.1.3.tm
  6. 430
      src/modules/overtype-999999.0a1.0.tm
  7. 2
      src/modules/overtype-buildversion.txt
  8. 3
      src/modules/punk/ansi-999999.0a1.0.tm
  9. 241
      src/modules/punk/lib-999999.0a1.0.tm
  10. 6
      src/modules/punk/path-999999.0a1.0.tm
  11. 3
      src/modules/punk/repl-999999.0a1.0.tm
  12. 12
      src/modules/punk/safe-999999.0a1.0.tm
  13. 18
      src/modules/punkcheck-0.1.0.tm
  14. 35
      src/modules/textblock-999999.0a1.0.tm
  15. 148
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.2.tm
  16. 241
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm
  17. 3
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm
  18. 18
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm
  19. 32
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  20. 148
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/dictn-0.1.2.tm
  21. 241
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm
  22. 3
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm
  23. 18
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm
  24. 32
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  25. 148
      src/vfs/_vfscommon.vfs/modules/dictn-0.1.2.tm
  26. 82
      src/vfs/_vfscommon.vfs/modules/overtype-1.7.3.tm
  27. 5199
      src/vfs/_vfscommon.vfs/modules/overtype-1.7.4.tm
  28. 241
      src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.5.tm
  29. 3
      src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm
  30. 18
      src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm
  31. 32
      src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm

148
src/bootsupport/modules/dictn-0.1.2.tm

@ -25,17 +25,46 @@
namespace eval dictn {
namespace export {[a-z]*}
namespace ensemble create
namespace eval argdoc {
variable PUNKARGS
#non-colour SGR codes
set I "\x1b\[3m" ;# [a+ italic]
set NI "\x1b\[23m" ;# [a+ noitalic]
set B "\x1b\[1m" ;# [a+ bold]
set N "\x1b\[22m" ;# [a+ normal]
set T "\x1b\[1\;4m" ;# [a+ bold underline]
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline]
}
}
## ::dictn::append
#This can of course 'ruin' a nested dict if applied to the wrong element
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl:
# %set list {a b {c d}}
# %append list x
# a b {c d}x
# IOW - don't do that unless you really know that's what you want.
#
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::append
@cmd -name dictn::append\
-summary\
"Append a single string to the value at dict path."\
-help\
"Append a single string to the value at a given dictionary path.
This can of course 'ruin' a nested dict if applied to the wrong element
- i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl:
%set list {a b {c d}}
%append list x
a b {c d}x
IOW - don't do that unless you really know that's what you want.
Note than unlike dict append - only a single value is accepted for appending.
"
@values -min 2 -max 3
dictvar -type string
path -type list
value -type any -default "" -optional 1
}]
}
proc ::dictn::append {dictvar path {value {}}} {
if {[llength $path] == 1} {
uplevel 1 [list dict append $dictvar $path $value]
@ -43,7 +72,7 @@ proc ::dictn::append {dictvar path {value {}}} {
upvar 1 $dictvar dvar
::set str [dict get $dvar {*}$path]
append str $val
append str $value
dict set dvar {*}$path $str
}
}
@ -73,6 +102,25 @@ proc ::dictn::for {keyvalvars dictval path body} {
proc ::dictn::get {dictval {path {}}} {
return [dict get $dictval {*}$path]
}
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::getn
@cmd -name dictn::getn\
-summary\
"Get one or more paths in a dict simultaneously."\
-help\
""
@values -min 1 -max -1
dictvar -type string
path -type list -multiple 1
}]
}
proc ::dictn::getn {dictval args} {
if {![llength $args]} {
return [::tcl::dict::get $dictval]
}
lmap path $args {::tcl::dict::get $dictval {*}$path}
}
if {[info commands ::tcl::dict::getdef] ne ""} {
@ -85,10 +133,18 @@ if {[info commands ::tcl::dict::getdef] ne ""} {
return [dict getdef $dictval {*}$path $default]
}
proc ::dictn::incr {dictvar path {increment {}} } {
if {$increment eq ""} {
::set increment 1
proc ::dictn::incr {dictvar path {increment 1} } {
upvar 1 $dictvar dvar
if {[llength $path] == 1} {
return [::tcl::dict::incr dvar $path $increment]
}
if {[::tcl::info::exists dvar]} {
::set increment [expr {[::tcl::dict::getdef $dvar {*}$path 0] + $increment}]
}
return [::tcl::dict::set dvar {*}$path $increment]
}
#test - compare disassembly
proc ::dictn::incr2 {dictvar path {increment 1} } {
if {[llength $path] == 1} {
uplevel 1 [list dict incr $dictvar $path $increment]
} else {
@ -233,6 +289,33 @@ proc ::dictn::set {dictvar path newval} {
return [dict set dvar {*}$path $newval]
}
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::setn
@cmd -name dictn::setn\
-summary\
"Set one or more paths in a dict to value(s)"\
-help\
""
@values -min 3 -max -1
dictvar -type string
path_newval -type {path newval} -multiple 1
}]
}
proc ::dictn::setn {dictvar args} {
if {[llength $args] == 0} {
error "dictn::setn requires at least one <path> <newval> pair"
}
if {[llength $args] % 2 != 0} {
error "dictn::setn requires trailing <path> <newval> pairs"
}
upvar 1 $dictvar dvar
foreach {p v} $args {
::tcl::dict::set dvar {*}$p $v
}
return $dvar
}
proc ::dictn::size {dictval {path {}}} {
return [dict size [dict get $dictval {*}$path]]
}
@ -312,6 +395,46 @@ proc ::dictn::values {dictval {path {}} {glob {}}} {
}
}
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::with
@cmd -name dictn::with\
-summary\
"Execute script for each key at dict path."\
-help\
"Execute the Tcl script in body with the value for each key within the
given key-path mapped to either variables or keys in a specified array.
If the name of an array variable is not supplied for arrayvar,
dictn with behaves like dict with, except that it accepts a list
for the possibly nested key-path instead of separate arguments.
The subkeys of the dict at the given key-path will create variables
in the calling scope.
If an arrayvar is passed, an array of that name in the calling
scope will be populated with keys and values from the subkeys and
values of the dict at the given key-path."
@form -form standard
@values -min 3 -max 3
dictvar -type string
path -type list
body -type string
@form -form array
@values -min 4 -max 4
dictvar -type string
path -type list
arrayvar -type string -help\
"Name of array variable in which key values are
stored for the given dict path.
This prevents key values being used as variable
names in the calling scope, instead capturing them
as keys in the single specified array at the calling
scope."
body -type string
}]
}
# Standard form:
#'dictn with dictVariable path body'
#
@ -351,7 +474,10 @@ proc ::dictn::with {dictvar path args} {
::tcl::namespace::eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::dictn
}

241
src/bootsupport/modules/punk/lib-0.1.5.tm

@ -751,6 +751,27 @@ namespace eval punk::lib {
# -- ---
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lswap
@cmd -name punk::lib::lswap\
-summary\
"Swap list values in-place"\
-help\
"Similar to struct::list swap, except it fully supports basic
list index expressions such as 7-2 end-1 etc.
struct::list swap doesn't support 'end' offsets, and only
sometimes appears to support basic expressions, depending on the
expression compared to the list length."
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
proc lswap {lvar a z} {
upvar $lvar l
set len [llength $l]
@ -955,42 +976,69 @@ namespace eval punk::lib {
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lzip
@cmd -name punk::lib::lzip\
-summary\
"zip any number of lists together."\
-help\
"Conceptually equivalent to converting a list of rows
to a list of columns.
The number of returned lists (columns) will be equal to
the length of the longest supplied list (row).
If lengths of supplied lists don't match, empty strings
will be inserted in the resulting lists.
e.g lzip {a b c d e} {1 2 3 4} {x y z}
-> {a 1 x} {b 2 y} {c 3 z} {d 4 {}} {3 {} {}}
"
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
proc lzip {args} {
switch -- [llength $args] {
0 {return {}}
1 {return [lindex $args 0]}
2 {return [lzip2lists {*}$args]}
3 {return [lzip3lists {*}$args]}
4 {return [lzip4lists {*}$args]}
5 {return [lzip5lists {*}$args]}
6 {return [lzip6lists {*}$args]}
7 {return [lzip7lists {*}$args]}
8 {return [lzip8lists {*}$args]}
9 {return [lzip9lists {*}$args]}
10 {return [lzip10lists {*}$args]}
2 {return [::punk::lib::system::lzip2lists {*}$args]}
3 {return [::punk::lib::system::lzip3lists {*}$args]}
4 {return [::punk::lib::system::lzip4lists {*}$args]}
5 {return [::punk::lib::system::lzip5lists {*}$args]}
6 {return [::punk::lib::system::lzip6lists {*}$args]}
7 {return [::punk::lib::system::lzip7lists {*}$args]}
8 {return [::punk::lib::system::lzip8lists {*}$args]}
9 {return [::punk::lib::system::lzip9lists {*}$args]}
10 {return [::punk::lib::system::lzip10lists {*}$args]}
11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 {
set n [llength $args]
if {[info commands ::punk::lib::lzip${n}lists] eq ""} {
puts "calling ::punk::lib::Build_lzipn $n"
::punk::lib::Build_lzipn $n
if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} {
#puts "calling ::punk::lib::system::Build_lzipn $n"
::punk::lib::system::Build_lzipn $n
}
return [lzip${n}lists {*}$args]
return [::punk::lib::system::lzip${n}lists {*}$args]
}
default {
if {[llength $args] < 4000} {
set n [llength $args]
if {[info commands ::punk::lib::lzip${n}lists] eq ""} {
puts "calling ::punk::lib::Build_lzipn $n"
::punk::lib::Build_lzipn $n
if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} {
#puts "calling ::punk::lib::system::Build_lzipn $n"
::punk::lib::system::Build_lzipn $n
}
return [lzip${n}lists {*}$args]
return [::punk::lib::system::lzip${n}lists {*}$args]
} else {
return [lzipn {*}$args]
return [::punk::lib::lzipn {*}$args]
}
}
}
}
namespace eval system {
proc Build_lzipn {n} {
set arglist [list]
#use punk::lib::range which defers to lseq if available
@ -1005,10 +1053,10 @@ namespace eval punk::lib {
append body "\$[lindex $vars $i] "
}
append body "\}" \n
puts "proc punk::lib::lzip${n}lists {$arglist} \{"
puts "$body"
puts "\}"
proc ::punk::lib::lzip${n}lists $arglist $body
#puts "proc punk::lib::system::lzip${n}lists {$arglist} \{"
#puts "$body"
#puts "\}"
proc ::punk::lib::system::lzip${n}lists $arglist $body
}
#fastest is to know the number of lists to be zipped
@ -1053,6 +1101,7 @@ namespace eval punk::lib {
#2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?)
proc lzipn_tcl8 {args} {
#For tcl pre 9 (without lsearch -stride)
#wiki - courtesy JAL
set list_l $args
set zip_l []
@ -1068,6 +1117,7 @@ namespace eval punk::lib {
return $zip_l
}
proc lzipn_tcl9a {args} {
#For Tcl 9+ (with lsearch -stride)
#compared to wiki version
#comparable for lists len <3 or number of args < 3
#approx 2x faster for large lists or more lists
@ -1121,15 +1171,38 @@ namespace eval punk::lib {
}
return $zip_l
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lzipn
@cmd -name punk::lib::lzipn\
-summary\
"zip any number of lists together (unoptimised)."\
-help\
"Conceptually equivalent to converting a list of rows
to a list of columns.
See lzip which provides the same functionality but with
optimisations depending on the number of supplied lists.
"
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
#keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible
if {![package vsatisfies [package present Tcl] 9.0-] || [dict get [punk::lib::check::has_tclbug_lsearch_strideallinline] bug]} {
#-stride either not available - or has bug preventing use of main algorithm below
proc lzipn {args} [info body ::punk::lib::lzipn_tcl8]
proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl8]
} else {
proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a]
proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl9a]
}
namespace import ::punk::args::lib::tstr
namespace eval argdoc {
@ -2291,13 +2364,31 @@ namespace eval punk::lib {
proc is_list_all_ni_list2 {a b} $body
}
#somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist
#struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on,
# especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg)
proc ldiff {fromlist removeitems} {
if {[llength $removeitems] == 0} {return $fromlist}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::ldiff
@cmd -name punk::lib::ldiff\
-summary\
"Difference consisting of items with removeitems removed."\
-help\
"Somewhat like struct::set difference, but order preserving, and doesn't
treat as a 'set' so preserves any duplicates in items.
struct::set difference may happen to preserve ordering when items are
integers, but order can't be relied on, especially as struct::set has
2 differening implementations (tcl vs critcl) which return results with
different ordering to each other and different deduping behaviour in
some cases (e.g when 2nd arg is empty)"
@values -min 2 -max 2
items -type list
removeitems -type list
}]
}
proc ldiff {items removeitems} {
if {[llength $removeitems] == 0} {return $items}
set result {}
foreach item $fromlist {
foreach item $items {
if {$item ni $removeitems} {
lappend result $item
}
@ -2361,6 +2452,28 @@ namespace eval punk::lib {
return [array names tmp]
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lunique_unordered
@cmd -name punk::lib::lunique_unordered\
-summary\
"unique values in list"\
-help\
"Return unique values in provided list.
This removes duplicates but *may* rearrange the
order of the returned elements compared to the
original list.
When struct::set is available this will be used
for the implementation, as it can be *slightly*
faster if acceleration is present. When struct::set
is not available it will fallback to lunique and
provide the same functionality with order preserved."
@values -min 1 -max 1
list -type list
}]
}
#default/fallback implementation
proc lunique_unordered {list} {
lunique $list
@ -2371,13 +2484,33 @@ namespace eval punk::lib {
struct::set union $list {}
}
} else {
puts stderr "WARNING: struct::set union <list> <emptylist> no longer dedupes!"
#struct::set union operates on a 'set' - so this probably won't change, and hopefully is
#consistent across unacelerated versions and those implemented in accelerators,
#but if it ever does change - be a little noisy about it.
puts stderr "punk::lib WARNING: struct::set union <list> <emptylist> no longer dedupes!"
#we could also test a sequence of: struct::set add
}
}
#order-preserving
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lunique
@cmd -name punk::lib::lunique\
-summary\
"Order-preserving unique values in list"\
-help\
"Return unique values in provided list.
This removes duplicates whilst preserving the
original order of the provided list.
When struct::set is available with acceleration,
lunique_unordered may be slightly faster."
@values -min 1 -max 1
list -type list
}]
}
proc lunique {list} {
set new {}
foreach item $list {
@ -2569,7 +2702,7 @@ namespace eval punk::lib {
To validate if an indexset is strictly within range, both the length of the data and the base would
need to be considered.
The normal 'range' specifier is ..
The normal 'range' specifier is .. but can be of the form .x. where x is the step value.
The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire
range of valid values.
e.g the following are all valid ranges
@ -2581,6 +2714,9 @@ namespace eval punk::lib {
(index 2 to 11)
..
(all indices)
.3.
(1st index and every 3rd index thereafter)
Common whitespace elements space,tab,newlines are ignored.
Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands,
e.g end-2 or 2+2.
@ -2670,20 +2806,19 @@ namespace eval punk::lib {
.-1. would represent end to base with step -1
If start is omitted and only the end is supplied:
The default step is 1 indicating ascension and the missing end is equivalent to 'end'
indexset_resolve 5 2..
-> 2 3 4
The default end is the base if the step is negative
indexset_resolve 5 2.-1.
-> 2 1 0
If end is omitted and onlthe start is supplied:
The default step is 1 indicating ascension and the missing start is equivalent to the base.
indexset_resolve 5 ..2
-> 0 1 2
The default start is 'end' if the step is negative
indexset_resolve 5 .-1.2
-> 4 3 2
If end is omitted and only the start is supplied:
The default step is 1 indicating ascension and the missing end is equivalent to 'end'
indexset_resolve 5 2..
-> 2 3 4
The default end is the base if the step is negative
indexset_resolve 5 2.-1.
-> 2 1 0
Like the tcl9 lseq command - a step (by) value of zero produces no results.
@ -2703,7 +2838,7 @@ namespace eval punk::lib {
indexset examples:
These assume the default 0-based indices (base == 0)
These assume the default 0-based indices (-base 0)
1,3..
output the index 1 (2nd item) followed by all from index 3 to the end.
@ -3604,7 +3739,7 @@ namespace eval punk::lib {
@id -id ::punk::lib::gcd
@cmd -name punk::lib::gcd\
-summary\
"Gretest common divisor of m and n."\
"Greatest common divisor of m and n."\
-help\
"Return the greatest common divisor of m and n.
Straight from Lars Hellström's math::numtheory library in Tcllib
@ -3643,12 +3778,22 @@ namespace eval punk::lib {
return $m
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lcm
@cmd -name punk::lib::lcm\
-summary\
"Lowest common multiple of m and n."\
-help\
"Return the lowest common multiple of m and n.
Straight from Lars Hellström's math::numtheory library in Tcllib"
@values -min 2 -max 2
m -type integer
n -type integer
}]
}
proc lcm {n m} {
#*** !doctools
#[call [fun gcd] [arg n] [arg m]]
#[para]Return the lowest common multiple of m and n
#[para]Straight from Lars Hellström's math::numtheory library in Tcllib
#[para]
set gcd [gcd $n $m]
return [expr {$n*$m/$gcd}]
}

3
src/bootsupport/modules/punk/repl-0.1.2.tm

@ -1036,7 +1036,8 @@ namespace eval punk::repl::class {
# set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
# incr nextrow -1
#}
set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
#set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
ledit o_rendered_lines $cursor_row_idx $cursor_row_idx-1 ""
set o_cursor_col 1
}

18
src/bootsupport/modules/punkcheck-0.1.0.tm

@ -323,7 +323,8 @@ namespace eval punkcheck {
if {$isnew} {
lappend record_list $o_fileset_record
} else {
set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record]
#set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record]
ledit record_list $oldposition $oldposition-1 $o_fileset_record
}
if {$o_operation ne "QUERY"} {
punkcheck::save_records_to_file $record_list $punkcheck_file
@ -536,7 +537,8 @@ namespace eval punkcheck {
set existing_header_posn [dict get $resultinfo position]
if {$existing_header_posn == -1} {
set this_installer_record [punkcheck::recordlist::new_installer_record $o_name]
set o_record_list [linsert $o_record_list 0 $this_installer_record]
#set o_record_list [linsert $o_record_list 0 $this_installer_record]
ledit o_record_list -1 -1 $this_installer_record
} else {
set this_installer_record [dict get $resultinfo record]
}
@ -616,7 +618,8 @@ namespace eval punkcheck {
set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records]
set existing_header_posn [dict get $persistedinfo position]
if {$existing_header_posn == -1} {
set file_records [linsert $file_records 0 $this_installer_record]
#set file_records [linsert $file_records 0 $this_installer_record]
ledit file_records -1 -1 $this_installer_record
} else {
lset file_records $existing_header_posn $this_installer_record
}
@ -710,7 +713,8 @@ namespace eval punkcheck {
if {$existing_header_posn == -1} {
#not found - prepend
set record_list [linsert $record_list 0 $this_installer_record]
#set record_list [linsert $record_list 0 $this_installer_record]
ledit record_list -1 -1 $this_installer_record
} else {
#replace
lset record_list $existing_header_posn $this_installer_record
@ -791,7 +795,8 @@ namespace eval punkcheck {
if {$isnew} {
lappend record_list $file_record
} else {
set record_list [linsert $record_list[unset record_list] $oldposition $file_record]
#set record_list [linsert $record_list[unset record_list] $oldposition $file_record]
ledit record_list $oldposition $oldposition-1 $file_record
}
save_records_to_file $record_list $punkcheck_file
@ -1191,7 +1196,8 @@ namespace eval punkcheck {
# dst is: base/sub = sub
while {$baselen > 0} {
set dst [linsert $dst 0 ..]
#set dst [linsert $dst 0 ..]
ledit dst -1 -1 ..
incr baselen -1
}
set dst [file join {*}$dst]

32
src/bootsupport/modules/textblock-0.1.3.tm

@ -4480,7 +4480,8 @@ tcl::namespace::eval textblock {
set code_idx 3
foreach {pt code} [lrange $parts 2 end] {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts $code_idx+1 $base]
#set parts [linsert $parts $code_idx+1 $base]
ledit parts $code_idx+1 $code_idx $base
}
incr code_idx 2
}
@ -4504,12 +4505,14 @@ tcl::namespace::eval textblock {
#first pt & code
if {$pt ne ""} {
#leading plaintext
set parts [linsert $parts 0 $base]
#set parts [linsert $parts 0 $base]
ledit parts -1 -1 $base
incr offset
}
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts [expr {$code_idx+1+$offset}] $base]
#ledit parts [expr {$code_idx+1+$offset}] $code_idx+$offset $base
incr offset
}
incr code_idx 2
@ -5371,6 +5374,9 @@ tcl::namespace::eval textblock {
r-1 {
if {[lindex $line_chunks end] eq ""} {
set line_chunks [linsert $line_chunks end-2 $pad]
#breaks layout e.g subtables in: i i
#why?
#ledit line_chunks end-2 end-3 $pad
} else {
lappend line_chunks $pad
}
@ -5379,13 +5385,16 @@ tcl::namespace::eval textblock {
lappend line_chunks $pad
}
l-0 {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
l-1 {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
#set line_chunks [linsert $line_chunks 2 $pad]
ledit line_chunks 2 1 $pad
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
l-2 {
@ -5393,10 +5402,12 @@ tcl::namespace::eval textblock {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
}
@ -5466,14 +5477,17 @@ tcl::namespace::eval textblock {
#} else {
# set line_chunks [linsert $line_chunks 0 $pad]
#}
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
l-1 {
#set line_chunks [linsert $line_chunks 0 $pad]
set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks]
}
l-2 {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
}

430
src/modules/overtype-999999.0a1.0.tm

@ -493,13 +493,14 @@ tcl::namespace::eval overtype {
switch -- $scheme {
0 {
#one big chunk
set inputchunks [list $overblock]
set inputchunks [list mixed $overblock]
}
1 {
#todo
set inputchunks [punk::ansi::ta::split_codes $overblock]
}
2 {
#todo
#split into lines if possible first - then into plaintext/ansi-sequence chunks ?
set inputchunks [list ""] ;#put an empty plaintext split in for starters
set i 1
@ -516,6 +517,7 @@ tcl::namespace::eval overtype {
}
}
3 {
#todo
#it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice
set lflines [list]
set inputchunks [split $overblock \n]
@ -533,10 +535,10 @@ tcl::namespace::eval overtype {
4 {
set inputchunks [list]
foreach ln [split $overblock \n] {
lappend inputchunks $ln\n
lappend inputchunks [list mixed $ln\n]
}
if {[llength $inputchunks]} {
lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1]
lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1]
}
}
}
@ -567,23 +569,54 @@ tcl::namespace::eval overtype {
set loop 0
#while {$overidx < [llength $inputchunks]} { }
set renderedrow ""
while {[llength $inputchunks]} {
#set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx ""
set overtext [lpop inputchunks 0]
if {![tcl::string::length $overtext]} {
#set overtext [lpop inputchunks 0] ;#could be a list 'ansisplit' or text 'plain|mixed'
lassign [lpop inputchunks 0] overtext_type overtext
#use eq test with emptystring instead of 'string length' - test for emptiness shouldn't cause shimmering if popped inputchunks member if an 'ansisplit' list
if {$overtext eq ""} {
incr loop
continue
}
#puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----"
set undertext [lindex $outputlines [expr {$row -1}]]
set renderedrow $row
#renderline pads each underaly line to width with spaces and should track where end of data is
#set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext]
switch -- $overtext_type {
mixed {
set overtext $replay_codes_overlay$overtext
}
ansisplit {
ledit overtext -1 -1 "" $replay_codes_overlay
}
default {
error "renderspace unsupported overtext type: $overtext_type overtext: $overtext"
}
}
######################
#debug
#set partinfo ""
#if {$overtext_type eq "ansisplit"} {
# set partinfo [llength $overtext]
#} else {
# set partinfo [string length $overtext]
#}
#if {$renderedrow eq $row} {
# puts -nonewline stderr <$row>$overtext_type$partinfo
#} else {
# puts -nonewline stderr \n<$row>$overtext_type$partinfo
#}
#if {$overtext_type eq "mixed"} {
# puts -nonewline stderr "\n[ansistring VIEW $overtext]\n"
#}
######################
set renderedrow $row
if {[tcl::dict::exists $replay_codes_underlay $row]} {
set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext
}
@ -604,6 +637,7 @@ tcl::namespace::eval overtype {
-expand_right $opt_expand_right\
-cursor_column $col\
-cursor_row $row\
-overtext_type $overtext_type\
]
set rinfo [renderline {*}$renderopts $undertext $overtext]
@ -623,6 +657,7 @@ tcl::namespace::eval overtype {
set overflow_right_column [tcl::dict::get $rinfo overflow_right_column]
set unapplied [tcl::dict::get $rinfo unapplied]
set unapplied_list [tcl::dict::get $rinfo unapplied_list]
set unapplied_ansisplit [tcl::dict::get $rinfo unapplied_ansisplit]
set post_render_col [tcl::dict::get $rinfo cursor_column]
set post_render_row [tcl::dict::get $rinfo cursor_row]
set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position]
@ -685,7 +720,7 @@ tcl::namespace::eval overtype {
set nextprefix ""
set nextprefix_list [list]
#todo - handle potential insertion mode as above for cursor restore?
@ -774,13 +809,22 @@ tcl::namespace::eval overtype {
lappend outputlines ""
}
}
set existingdata [lindex $outputlines [expr {$post_render_row -1}]]
set lastdatacol [punk::ansi::printing_length $existingdata]
if {$lastdatacol < $renderwidth} {
set col [expr {$lastdatacol+1}]
} else {
set col $renderwidth
}
# ----
# review
set col $post_render_col
#just because it's out of range of the renderwidth - doesn't mean a move down should jump to witin the range - 2025
#----
#set existingdata [lindex $outputlines [expr {$post_render_row -1}]]
#set lastdatacol [punk::ansi::printing_length $existingdata]
#set col [expr {$lastdatacol+1}]
#if {$lastdatacol < $renderwidth} {
# set col [expr {$lastdatacol+1}]
#} else {
# set col $renderwidth
#}
}
}
@ -827,6 +871,9 @@ tcl::namespace::eval overtype {
set foldline [tcl::dict::get $sub_info result]
tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
#todo!!!
# 2025 fix - this does nothing - so what uses it?? create a test!
linsert outputlines $renderedrow $foldline
#review - row & col set by restore - but not if there was no save..
}
@ -919,9 +966,22 @@ tcl::namespace::eval overtype {
set edit_mode 0
if {$edit_mode} {
set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied]
#set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied]
#JMN
#ledit inputchunks -1 -1 $overflow_right$unapplied
set pt_ansi_pt [punk::ansi::ta::split_codes_single $overflow_right]
#join the trailing and leading pt parts of the 2 lists
ledit pt_ansi_pt end end "[lindex $pt_ansi_pt end][lindex $unapplied_ansisplit 0]"
lappend pt_ansi_pt [lrange $unapplied_ansisplit 1 end]
ledit inputchunks -1 -1 [list ansisplit $pt_ansi_pt] ;#combined overflow_right and unapplied - in ansisplit form
set overflow_right ""
set unapplied ""
set unapplied_list [list]
set unapplied_ansisplit [list]
set row $post_render_row
#set col $post_render_col
set col $opt_startcolumn
@ -1038,7 +1098,8 @@ tcl::namespace::eval overtype {
set col $post_render_col
if {$insert_lines_above > 0} {
set row $renderedrow
set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]]
#set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]]
ledit outputlines $renderedrow-1 $renderedrow-2 {*}[lrepeat $insert_lines_above ""]
incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above
#? set row $post_render_row #can renderline tell us?
}
@ -1157,30 +1218,71 @@ tcl::namespace::eval overtype {
}
overflow {
#normal single-width grapheme overflow
#puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]"
#puts stderr "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]"
#renderspace gives us an overflow when there is a grapheme followed by a non-grapheme
#This gives us some possible(probable) leading ANSI (which is probably SGR, or it would have triggered something else)
#followed by a sequence of 1 or more graphemes and some more unprocessed ANSI (which could be anything: SGR,movement etc)
#we want to strip out this leading run of graphemes
#NOTE: 2025 - comment is obsolete/inaccurate. We only ever get 1 grapheme - as prior were consumed/ignored by renderline
#REVIEW!!!
#example trigger: textblock::frame -width 80 [ansicat us-pump_up_the_jam-355.ans 355x100]
set row $post_render_row ;#renderline will not advance row when reporting overflow char
if {[tcl::dict::get $vtstate autowrap_mode]} {
incr row
set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ??
} else {
set col $post_render_col
#set unapplied "" ;#this seems wrong?
#set unapplied [tcl::string::range $unapplied 1 end]
#The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs
#There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate
#We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow'
set drop_graphemes [list] ;#list of contiguous grapheme indices
set new_unapplied_list [list]
set unapplied_ansisplit [list ""]
set idx 0
set next_grapheme_index -1
foreach u $unapplied_list {
if {![punk::ansi::ta::detect $u]} {
set next_grapheme_index $idx
break
#puts stderr "g$idx:$u"
if {![llength $drop_graphemes] || $idx == [lindex $drop_graphemes end]+1} {
#we are in the first run of uninterrupted graphemes
#drop by doing nothing with it here
lappend drop_graphemes $idx
} else {
lappend new_unapplied_list $u
ledit unapplied_ansisplit end end "[lindex $unapplied_ansisplit end]$u"
}
} else {
lappend new_unapplied_list $u
lappend unapplied_ansisplit $u ""
}
incr idx
}
assert {$next_grapheme_index >= 0}
#drop the overflow grapheme - keeping all codes in place.
set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""]
#debug
if {[llength $drop_graphemes]} {
set idx0 [lindex $drop_graphemes 0]
set dbg ""
if {$idx0 > 0} {
for {set i 0} {$i < $idx0} {incr i} {
#leading SGR
append dbg [lindex $unapplied_list $i]
}
}
foreach idx $drop_graphemes {
append dbg [lindex $unapplied_list $idx]
}
puts stderr "dropped[llength $drop_graphemes]:$dbg\x1b\[m"
}
set unapplied [join $new_unapplied_list ""]
if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} {
set unapplied_ansisplit [list]
}
set unapplied_list $new_unapplied_list
#we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines
set overflow_handled 1
@ -1204,7 +1306,11 @@ tcl::namespace::eval overtype {
}
incr idx
}
set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""]
#set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""]
ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index
set unapplied [join $unapplied_list ""]
#review - inefficient to re-split (return unapplied_tagged instead of unapplied_ansisplit?)
set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied]
} else {
set col $opt_startcolumn
incr row
@ -1222,7 +1328,12 @@ tcl::namespace::eval overtype {
}
incr idx
}
set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""]
#set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""]
ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index
set unapplied [join $unapplied_list ""]
#review - inefficient
puts -nonewline stderr .
set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied]
}
}
@ -1293,10 +1404,25 @@ tcl::namespace::eval overtype {
}
if {!$overflow_handled} {
append nextprefix $overflow_right
#append nextprefix $overflow_right
set overflow_right_pt_code_pt [punk::ansi::ta::split_codes_single $overflow_right]
if {![llength $nextprefix_list]} {
set nextprefix_list $overflow_right_pt_code_pt
} else {
#merge tail and head
ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $overflow_right_pt_code_pt 0]"
lappend nextprefix_list {*}[lrange $overflow_right_pt_code_pt 1 end]
}
}
append nextprefix $unapplied
#append nextprefix $unapplied
if {![llength $nextprefix_list]} {
set nextprefix_list $unapplied_ansisplit
} else {
#merge tail and head
ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $unapplied_ansisplit 0]"
lappend nextprefix_list {*}[lrange $unapplied_ansisplit 1 end]
}
if 0 {
if {$nextprefix ne ""} {
@ -1310,8 +1436,10 @@ tcl::namespace::eval overtype {
}
}
if {$nextprefix ne ""} {
set inputchunks [linsert $inputchunks 0 $nextprefix]
if {[llength $nextprefix_list]} {
#set inputchunks [linsert $inputchunks 0 $nextprefix]
#JMN - assume backwards compat ledit available from punk::lib (for tcl <9)
ledit inputchunks -1 -1 [list ansisplit $nextprefix_list]
}
@ -1854,7 +1982,8 @@ tcl::namespace::eval overtype {
return [join $outputlines \n]
}
variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches
#variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches
variable optimise_ptruns 5
@ -1931,7 +2060,7 @@ tcl::namespace::eval overtype {
-cursor_restore_attributes -default ""
-cp437 -default 0 -type boolean
-experimental -default {}
-overtext_type -type string -choices {mixed plain ansisplit} -default mixed
@values -min 2 -max 2
undertext -type string -help\
"A single line of text which may contain pre-rendered ANSI.
@ -2026,7 +2155,10 @@ tcl::namespace::eval overtype {
-cursor_restore_attributes ""\
-cp437 0\
-experimental {}\
-overtext_type mixed\
]
#-overtext_type plain|mixed|ansisplit
#-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller
#cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return
@ -2040,7 +2172,7 @@ tcl::namespace::eval overtype {
switch -- $k {
-experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row
- -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode
- -info - -exposed1 - -exposed2 - -cursor_restore_attributes {
- -info - -exposed1 - -exposed2 - -cursor_restore_attributes - -overtext_type {
tcl::dict::set opts $k $v
}
default {
@ -2055,6 +2187,7 @@ tcl::namespace::eval overtype {
set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay
set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay
set opt_row_context [tcl::dict::get $opts -cursor_row]
set opt_overtext_type [tcl::dict::get $opts -overtext_type]
if {[string length $opt_row_context]} {
if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } {
error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'"
@ -2128,12 +2261,19 @@ tcl::namespace::eval overtype {
#set under [textutil::tabify::untabify2 $under]
set under [textutil::tabify::untabifyLine $under $tw]
}
#review - is untabifying sensible at this point??
if {$opt_overtext_type eq "ansisplit"} {
#todo - something for each pt part?
} else {
#plain|mixed
if {[string first \t $over] >= 0} {
#set overdata [textutil::tabify::untabify2 $over]
set overdata [textutil::tabify::untabifyLine $over $tw]
}
}
}
}
#-------
#ta_detect ansi and do simpler processing?
@ -2178,25 +2318,9 @@ tcl::namespace::eval overtype {
set is_ptrun [regexp $re $pt]
}
if {$is_ptrun} {
#switch -- $p1 {
# " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? -
# a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y -
# z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
# set width 1
# }
# default {
# if {$p1 eq "\u0000"} {
# #use null as empty cell representation - review
# #use of this will probably collide with some application at some point
# #consider an option to set the empty cell character
# set width 1
# } else {
# set width [grapheme_width_cached $p1] ;# when zero???
# }
# }
#}
set width [grapheme_width_cached $p1] ;# when zero???
set ptlen [string length $pt]
#puts -nonewline stderr !$ptlen!
if {$width <= 1} {
#review - 0 and 1?
incr i_u $ptlen
@ -2415,12 +2539,22 @@ tcl::namespace::eval overtype {
set startpadding [string repeat " " [expr {$opt_colstart -1}]]
#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency
if {$startpadding ne "" || $overdata ne ""} {
if {$opt_overtext_type eq "ansisplit"} {
set overmap $overdata
lset overmap 0 "$startpadding[lindex $overmap 0]"
} else {
if {[punk::ansi::ta::detect $overdata]} {
set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata]
#TODO!! rework this.
#e.g 200K+ input file with no newlines - we are wastefully calling split_codes_single repeatedly on mostly the same data.
#set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata]
set overmap [punk::ansi::ta::split_codes_single $overdata]
lset overmap 0 "$startpadding[lindex $overmap 0]"
} else {
#single plaintext part
set overmap [list $startpadding$overdata]
}
}
} else {
set overmap [list]
}
@ -2452,9 +2586,13 @@ tcl::namespace::eval overtype {
set o_gxstack [list]
set pt_overchars ""
set i_o 0
set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use
#experiment
set overlay_grapheme_control_stacks [list]
#REVIEW - even if we pass in a pre-split overtext (-overtext_type ansisplit)
#we are re-generating the overlay_grapheme_control_stacks list each time
#this is a big issue when overtext is not broken into lines, but is just a big long ansi and/or plain text string.
#todo - return also the unapplied portion of the overlay_grapheme_control_stacks list??
foreach {pt code} $overmap {
if {$pt ne ""} {
#todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between)
@ -2482,6 +2620,7 @@ tcl::namespace::eval overtype {
#could be edge cases for runs at line end? (should be ok as we include trailing \n in our data)
set len [string length $pt]
set g_element [list g $p1]
#puts -nonewline stderr "!$len!"
#lappend overstacks {*}[lrepeat $len $o_codestack]
#lappend overstacks_gx {*}[lrepeat $len $o_gxstack]
@ -2665,6 +2804,7 @@ tcl::namespace::eval overtype {
set unapplied "" ;#if we break for move row (but not for /v ?)
set unapplied_list [list]
set unapplied_ansisplit [list ""] ;#pt code ... pt
set insert_lines_above 0 ;#return key
set insert_lines_below 0
@ -2723,10 +2863,14 @@ tcl::namespace::eval overtype {
set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch]
set chars [string map [list \n "\x1b\[00001E"] $chars]
if {[llength [split $chars ""]] > 1} {
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
#prefix the unapplied controls with the string version of this control
set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]]
#set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]]
#JMN - backwards compat ledit from punk::lib for tcl <9
ledit unapplied_list -1 -1 {*}[split $chars ""]
set unapplied [join $unapplied_list ""]
lset unapplied_ansisplit 0 $chars ;#no existing ?
#incr idx_over
break
} else {
@ -2758,7 +2902,7 @@ tcl::namespace::eval overtype {
#linefeed at column 1
#leave the overflow_idx ;#? review
set instruction lf_start ;#specific instruction for newline at column 1
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
break
} elseif {$overflow_idx != -1 && $idx == $overflow_idx} {
#linefeed after final column
@ -2766,7 +2910,7 @@ tcl::namespace::eval overtype {
incr cursor_row
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
break
} else {
#linefeed occurred in middle or at end of text
@ -2778,12 +2922,12 @@ tcl::namespace::eval overtype {
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
}
set instruction lf_mid
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
break
} else {
incr cursor_row
#don't adjust the overflow_idx
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction lf_mid
break ;# could have overdata following the \n - don't keep processing
}
@ -2811,7 +2955,7 @@ tcl::namespace::eval overtype {
set flag 0
if $flag {
#review - conflicting requirements? Need a different sequence for destructive interactive backspace?
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction backspace_at_start
break
}
@ -2831,7 +2975,7 @@ tcl::namespace::eval overtype {
incr cursor_row
set overflow_idx $idx
#idx_over has already been incremented as this is both a movement-control and in some sense a grapheme
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction vt
break
}
@ -2853,7 +2997,7 @@ tcl::namespace::eval overtype {
set overflow_idx $idx
incr idx
incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used
priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci
priv::render_to_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci
#throw back to caller's loop - add instruction to caller as this is not the usual case
#caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line
set instruction overflow_splitchar
@ -2868,13 +3012,18 @@ tcl::namespace::eval overtype {
#REVIEW
set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control
lassign $next_gc next_type next_item
if {$autowrap_mode || $next_type ne "g"} {
if {$autowrap_mode} {
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]]
#set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
#don't incr idx beyond the overflow_idx
#idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied
incr idx_over -1
#priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too
#priv::render_to_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too
priv::render_this_unapplied $overlay_grapheme_control_list $gci ;#
set instruction overflow
break
} elseif {0 && $next_type ne "g"} {
incr idx_over -1
priv::render_this_unapplied $overlay_grapheme_control_list $gci ;#
set instruction overflow
break
@ -3083,10 +3232,14 @@ tcl::namespace::eval overtype {
#set within_undercols [expr {$idx <= $renderwidth-1}]
#set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item]
set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item]
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
#prefix the unapplied controls with the string version of this control
set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]]
#set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]]
#JMN
ledit unapplied_list -1 -1 {*}[split $chars ""]
set unapplied [join $unapplied_list ""]
#ledit unapplied_ansisplit -1 -1 $chars
lset unapplied_ansisplit 0 $chars ;#??
break
}
@ -3151,7 +3304,17 @@ tcl::namespace::eval overtype {
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
default {
puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
#JMN
puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. leadernorm: [ansistring VIEW -lf 1 $leadernorm] code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
puts stderr "ARGS:"
foreach a $args {
puts stderr " $a"
}
puts stderr -----
foreach {xpt ycode} $overmap {
puts stderr "t:'$xpt'"
puts stderr "c:[ansistring VIEW $ycode]"
}
#we haven't made a mapping for this
#could in theory be 1,2 or 3 in len
#although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches
@ -3222,7 +3385,7 @@ tcl::namespace::eval overtype {
#ensure rest of *overlay* is emitted to remainder
incr idx_over
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction up
#retain cursor_column
break
@ -3241,7 +3404,7 @@ tcl::namespace::eval overtype {
incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction down
#retain cursor_column
break
@ -3295,7 +3458,7 @@ tcl::namespace::eval overtype {
incr cursor_column $num ;#give our caller the necessary info as columns from start of row
#incr idx_over
#should be gci following last one applied
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction wrapmoveforward
break
} else {
@ -3379,7 +3542,7 @@ tcl::namespace::eval overtype {
} else {
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr cursor_column -$num
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction wrapmovebackward
break
}
@ -3407,7 +3570,7 @@ tcl::namespace::eval overtype {
set idx [expr {$cursor_column -1}]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction move
break
@ -3428,7 +3591,7 @@ tcl::namespace::eval overtype {
set idx [expr {$cursor_column - 1}]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction move
break
@ -3508,7 +3671,7 @@ tcl::namespace::eval overtype {
set idx [expr {$cursor_column -1}]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction move
break
}
@ -3542,7 +3705,7 @@ tcl::namespace::eval overtype {
if {[llength $outcols]} {
priv::render_erasechar 0 [llength $outcols]
}
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction clear_and_move
break
}
@ -3672,7 +3835,7 @@ tcl::namespace::eval overtype {
set cursor_row 1
incr idx_over
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction move ;#own instruction? decstbm?
break
}
@ -3807,25 +3970,39 @@ tcl::namespace::eval overtype {
set replay_codes_overlay ""
#}
#like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code
#like priv::render_to_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code
incr idx_over
set unapplied ""
set unapplied_list [list]
set unapplied_ansisplit [list ""] ;#remove below if nothing added
foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] {
lassign $gc type item
if {$type eq "gx0"} {
switch -- $type {
g {
lappend unapplied_list $item
ledit unapplied_ansisplit end end [string cat [lindex $unapplied_ansisplit end] $item]
}
gx0 {
if {$item eq "gx0_on"} {
lappend unapplied_list "\x1b(0"
lappend unapplied_ansisplit "\x1b(0" ""
} elseif {$item eq "gx0_off"} {
lappend unapplied_list "\x1b(B"
lappend unapplied_ansisplit "\x1b(B" ""
}
} else {
}
default {
lappend unapplied_list $item
lappend unapplied_ansisplit $item ""
}
}
#incr idx_over
}
set unapplied [join $unapplied_list ""]
if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} {
set unapplied_ansisplit [list]
}
#if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop.
set instruction restore_cursor
break
@ -4100,7 +4277,7 @@ tcl::namespace::eval overtype {
c {
#RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal!
puts stderr "renderline reset"
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction reset
break
}
@ -4110,7 +4287,7 @@ tcl::namespace::eval overtype {
#vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up"
puts stderr "renderline ESC D not fully implemented"
incr cursor_row
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction down
#retain cursor_column
break
@ -4144,7 +4321,7 @@ tcl::namespace::eval overtype {
set cursor_row 1
}
#ensure rest of *overlay* is emitted to remainder
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction up ;#need instruction for scroll-down?
#retain cursor_column
break
@ -4247,7 +4424,7 @@ tcl::namespace::eval overtype {
switch -exact -- $osc_code {
2 {
set newtitle [tcl::string::range $code_content 2 end]
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction [list set_window_title $newtitle]
break
}
@ -4307,7 +4484,7 @@ tcl::namespace::eval overtype {
#reset colour palette
#we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt
puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
priv::render_unapplied $overlay_grapheme_control_list $gci
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction [list reset_colour_palette]
break
}
@ -4534,6 +4711,10 @@ tcl::namespace::eval overtype {
} else {
set overflow_right_column [expr {$overflow_idx+1}]
}
if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} {
set unapplied_ansisplit [list]
}
set result [tcl::dict::create\
result $outstring\
visualwidth [punk::ansi::printing_length $outstring]\
@ -4543,6 +4724,7 @@ tcl::namespace::eval overtype {
overflow_right $overflow_right\
unapplied $unapplied\
unapplied_list $unapplied_list\
unapplied_ansisplit $unapplied_ansisplit\
insert_mode $insert_mode\
autowrap_mode $autowrap_mode\
crm_mode $crm_mode\
@ -4578,6 +4760,7 @@ tcl::namespace::eval overtype {
tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]]
tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]]
tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]]
tcl::dict::set result unapplied_ansisplit [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_ansisplit]]
tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]]
tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]]
tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]]
@ -4713,11 +4896,19 @@ tcl::namespace::eval overtype::priv {
tcl::dict::set cache_is_sgr $code $answer
return $answer
}
# better named render_to_unapplied?
proc render_unapplied {overlay_grapheme_control_list gci} {
proc render_to_unapplied {overlay_grapheme_control_list gci} {
upvar idx_over idx_over
#-----------------------------------------
#review - this is a lot of copies of the same thing.
# ultimately we want to reduce expensive things like redundant grapheme-splits
# perhaps unapplied_tagged of some sort e.g - {g <grapheme> g <grapheme> code <ansi> pt <text>} ??
upvar unapplied unapplied
upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split
upvar unapplied_ansisplit unapplied_ansisplit ;# pt ?code pt...?
#-----------------------------------------
upvar overstacks overstacks
upvar overstacks_gx overstacks_gx
upvar overlay_grapheme_control_stacks og_stacks
@ -4725,33 +4916,50 @@ tcl::namespace::eval overtype::priv {
#set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]]
set unapplied ""
set unapplied_list [list]
set unapplied_ansisplit [list ""]
#append unapplied [join [lindex $overstacks $idx_over] ""]
#append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]]
set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]]
if {$sgr_merged ne ""} {
lappend unapplied_list $sgr_merged
lappend unapplied_ansisplit $sgr_merged ""
}
switch -- [lindex $overstacks_gx $idx_over] {
"gx0_on" {
lappend unapplied_list "\x1b(0"
lappend unapplied_ansisplit "\x1b(0" ""
}
"gx0_off" {
lappend unapplied_list "\x1b(B"
lappend unapplied_ansisplit "\x1b(B" ""
}
}
foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] {
lassign $gc type item
#types g other sgr gx0
if {$type eq "gx0"} {
switch -- $type {
g {
lappend unapplied_list $item
lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item]
}
gx0 {
if {$item eq "gx0_on"} {
lappend unapplied_list "\x1b(0"
lappend unapplied_ansisplit "\x1b(0" ""
} elseif {$item eq "gx0_off"} {
lappend unapplied_list "\x1b(B"
lappend unapplied_ansisplit "\x1b(B" ""
}
} else {
}
default {
lappend unapplied_list $item
lappend unapplied_ansisplit $item ""
}
}
}
if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} {
set unapplied_ansisplit [list]
}
set unapplied [join $unapplied_list ""]
}
@ -4759,8 +4967,12 @@ tcl::namespace::eval overtype::priv {
#clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack
proc render_this_unapplied {overlay_grapheme_control_list gci} {
upvar idx_over idx_over
#--------------
upvar unapplied unapplied
upvar unapplied_list unapplied_list
upvar unapplied_ansisplit unapplied_ansisplit
#--------------
upvar overstacks overstacks
upvar overstacks_gx overstacks_gx
upvar overlay_grapheme_control_stacks og_stacks
@ -4768,32 +4980,49 @@ tcl::namespace::eval overtype::priv {
#set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]]
set unapplied ""
set unapplied_list [list]
set unapplied_ansisplit [list ""] ;#remove empty entry at end if nothing added
set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]]
if {$sgr_merged ne ""} {
lappend unapplied_list $sgr_merged
lappend unapplied_ansisplit $sgr_merged ""
}
switch -- [lindex $overstacks_gx $idx_over] {
"gx0_on" {
lappend unapplied_list "\x1b(0"
lappend unapplied_ansisplit "\x1b(0" ""
}
"gx0_off" {
lappend unapplied_list "\x1b(B"
lappend unapplied_ansisplit "\x1b(B" ""
}
}
foreach gc [lrange $overlay_grapheme_control_list $gci end] {
lassign $gc type item
#types g other sgr gx0
if {$type eq "gx0"} {
switch -- $type {
g {
lappend unapplied_list $item
lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item]
}
gx0 {
if {$item eq "gx0_on"} {
lappend unapplied_list "\x1b(0"
lappend unapplied_ansisplit "\x1b(0" ""
} elseif {$item eq "gx0_off"} {
lappend unapplied_list "\x1b(B"
lappend unapplied_ansisplit "\x1b(B" ""
}
} else {
}
default {
lappend unapplied_list $item
lappend unapplied_ansisplit $item ""
}
}
}
if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} {
set unapplied_ansisplit [list]
}
set unapplied [join $unapplied_list ""]
}
@ -4923,13 +5152,18 @@ tcl::namespace::eval overtype::priv {
} else {
#insert of single-width vs double-width when underlying is double-width?
if {$i < $nxt} {
set o [linsert $o $i $c]
#set o [linsert $o $i $c]
#JMN insert via ledit
ledit o $i $i-1 $c
} else {
lappend o $c
}
if {$i < [llength $ustacks]} {
set ustacks [linsert $ustacks $i $sgrstack]
set gxstacks [linsert $gxstacks $i $gx0stack]
#set ustacks [linsert $ustacks $i $sgrstack]
#set gxstacks [linsert $gxstacks $i $gx0stack]
#insert via ledit
ledit ustacks $i $i-1 $sgrstack
ledit gxstacks $i $i-1 $gx0stack
} else {
lappend ustacks $sgrstack
lappend gxstacks $gx0stack

2
src/modules/overtype-buildversion.txt

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

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

@ -4072,7 +4072,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
# \033 - octal. equivalently \x1b in hex which is more common in documentation
# empty list [a] should do reset - same for [a nonexistant]
# explicit reset at beginning of parameter list for a= (as opposed to a+)
set t [linsert $t[unset t] 0 0]
#set t [linsert $t[unset t] 0 0]
ledit t -1 -1 0
if {![llength $e]} {
set result "\x1b\[[join $t {;}]m"
} else {

241
src/modules/punk/lib-999999.0a1.0.tm

@ -751,6 +751,27 @@ namespace eval punk::lib {
# -- ---
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lswap
@cmd -name punk::lib::lswap\
-summary\
"Swap list values in-place"\
-help\
"Similar to struct::list swap, except it fully supports basic
list index expressions such as 7-2 end-1 etc.
struct::list swap doesn't support 'end' offsets, and only
sometimes appears to support basic expressions, depending on the
expression compared to the list length."
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
proc lswap {lvar a z} {
upvar $lvar l
set len [llength $l]
@ -955,42 +976,69 @@ namespace eval punk::lib {
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lzip
@cmd -name punk::lib::lzip\
-summary\
"zip any number of lists together."\
-help\
"Conceptually equivalent to converting a list of rows
to a list of columns.
The number of returned lists (columns) will be equal to
the length of the longest supplied list (row).
If lengths of supplied lists don't match, empty strings
will be inserted in the resulting lists.
e.g lzip {a b c d e} {1 2 3 4} {x y z}
-> {a 1 x} {b 2 y} {c 3 z} {d 4 {}} {3 {} {}}
"
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
proc lzip {args} {
switch -- [llength $args] {
0 {return {}}
1 {return [lindex $args 0]}
2 {return [lzip2lists {*}$args]}
3 {return [lzip3lists {*}$args]}
4 {return [lzip4lists {*}$args]}
5 {return [lzip5lists {*}$args]}
6 {return [lzip6lists {*}$args]}
7 {return [lzip7lists {*}$args]}
8 {return [lzip8lists {*}$args]}
9 {return [lzip9lists {*}$args]}
10 {return [lzip10lists {*}$args]}
2 {return [::punk::lib::system::lzip2lists {*}$args]}
3 {return [::punk::lib::system::lzip3lists {*}$args]}
4 {return [::punk::lib::system::lzip4lists {*}$args]}
5 {return [::punk::lib::system::lzip5lists {*}$args]}
6 {return [::punk::lib::system::lzip6lists {*}$args]}
7 {return [::punk::lib::system::lzip7lists {*}$args]}
8 {return [::punk::lib::system::lzip8lists {*}$args]}
9 {return [::punk::lib::system::lzip9lists {*}$args]}
10 {return [::punk::lib::system::lzip10lists {*}$args]}
11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 {
set n [llength $args]
if {[info commands ::punk::lib::lzip${n}lists] eq ""} {
puts "calling ::punk::lib::Build_lzipn $n"
::punk::lib::Build_lzipn $n
if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} {
#puts "calling ::punk::lib::system::Build_lzipn $n"
::punk::lib::system::Build_lzipn $n
}
return [lzip${n}lists {*}$args]
return [::punk::lib::system::lzip${n}lists {*}$args]
}
default {
if {[llength $args] < 4000} {
set n [llength $args]
if {[info commands ::punk::lib::lzip${n}lists] eq ""} {
puts "calling ::punk::lib::Build_lzipn $n"
::punk::lib::Build_lzipn $n
if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} {
#puts "calling ::punk::lib::system::Build_lzipn $n"
::punk::lib::system::Build_lzipn $n
}
return [lzip${n}lists {*}$args]
return [::punk::lib::system::lzip${n}lists {*}$args]
} else {
return [lzipn {*}$args]
return [::punk::lib::lzipn {*}$args]
}
}
}
}
namespace eval system {
proc Build_lzipn {n} {
set arglist [list]
#use punk::lib::range which defers to lseq if available
@ -1005,10 +1053,10 @@ namespace eval punk::lib {
append body "\$[lindex $vars $i] "
}
append body "\}" \n
puts "proc punk::lib::lzip${n}lists {$arglist} \{"
puts "$body"
puts "\}"
proc ::punk::lib::lzip${n}lists $arglist $body
#puts "proc punk::lib::system::lzip${n}lists {$arglist} \{"
#puts "$body"
#puts "\}"
proc ::punk::lib::system::lzip${n}lists $arglist $body
}
#fastest is to know the number of lists to be zipped
@ -1053,6 +1101,7 @@ namespace eval punk::lib {
#2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?)
proc lzipn_tcl8 {args} {
#For tcl pre 9 (without lsearch -stride)
#wiki - courtesy JAL
set list_l $args
set zip_l []
@ -1068,6 +1117,7 @@ namespace eval punk::lib {
return $zip_l
}
proc lzipn_tcl9a {args} {
#For Tcl 9+ (with lsearch -stride)
#compared to wiki version
#comparable for lists len <3 or number of args < 3
#approx 2x faster for large lists or more lists
@ -1121,15 +1171,38 @@ namespace eval punk::lib {
}
return $zip_l
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lzipn
@cmd -name punk::lib::lzipn\
-summary\
"zip any number of lists together (unoptimised)."\
-help\
"Conceptually equivalent to converting a list of rows
to a list of columns.
See lzip which provides the same functionality but with
optimisations depending on the number of supplied lists.
"
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
#keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible
if {![package vsatisfies [package present Tcl] 9.0-] || [dict get [punk::lib::check::has_tclbug_lsearch_strideallinline] bug]} {
#-stride either not available - or has bug preventing use of main algorithm below
proc lzipn {args} [info body ::punk::lib::lzipn_tcl8]
proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl8]
} else {
proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a]
proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl9a]
}
namespace import ::punk::args::lib::tstr
namespace eval argdoc {
@ -2291,13 +2364,31 @@ namespace eval punk::lib {
proc is_list_all_ni_list2 {a b} $body
}
#somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist
#struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on,
# especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg)
proc ldiff {fromlist removeitems} {
if {[llength $removeitems] == 0} {return $fromlist}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::ldiff
@cmd -name punk::lib::ldiff\
-summary\
"Difference consisting of items with removeitems removed."\
-help\
"Somewhat like struct::set difference, but order preserving, and doesn't
treat as a 'set' so preserves any duplicates in items.
struct::set difference may happen to preserve ordering when items are
integers, but order can't be relied on, especially as struct::set has
2 differening implementations (tcl vs critcl) which return results with
different ordering to each other and different deduping behaviour in
some cases (e.g when 2nd arg is empty)"
@values -min 2 -max 2
items -type list
removeitems -type list
}]
}
proc ldiff {items removeitems} {
if {[llength $removeitems] == 0} {return $items}
set result {}
foreach item $fromlist {
foreach item $items {
if {$item ni $removeitems} {
lappend result $item
}
@ -2361,6 +2452,28 @@ namespace eval punk::lib {
return [array names tmp]
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lunique_unordered
@cmd -name punk::lib::lunique_unordered\
-summary\
"unique values in list"\
-help\
"Return unique values in provided list.
This removes duplicates but *may* rearrange the
order of the returned elements compared to the
original list.
When struct::set is available this will be used
for the implementation, as it can be *slightly*
faster if acceleration is present. When struct::set
is not available it will fallback to lunique and
provide the same functionality with order preserved."
@values -min 1 -max 1
list -type list
}]
}
#default/fallback implementation
proc lunique_unordered {list} {
lunique $list
@ -2371,13 +2484,33 @@ namespace eval punk::lib {
struct::set union $list {}
}
} else {
puts stderr "WARNING: struct::set union <list> <emptylist> no longer dedupes!"
#struct::set union operates on a 'set' - so this probably won't change, and hopefully is
#consistent across unacelerated versions and those implemented in accelerators,
#but if it ever does change - be a little noisy about it.
puts stderr "punk::lib WARNING: struct::set union <list> <emptylist> no longer dedupes!"
#we could also test a sequence of: struct::set add
}
}
#order-preserving
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lunique
@cmd -name punk::lib::lunique\
-summary\
"Order-preserving unique values in list"\
-help\
"Return unique values in provided list.
This removes duplicates whilst preserving the
original order of the provided list.
When struct::set is available with acceleration,
lunique_unordered may be slightly faster."
@values -min 1 -max 1
list -type list
}]
}
proc lunique {list} {
set new {}
foreach item $list {
@ -2569,7 +2702,7 @@ namespace eval punk::lib {
To validate if an indexset is strictly within range, both the length of the data and the base would
need to be considered.
The normal 'range' specifier is ..
The normal 'range' specifier is .. but can be of the form .x. where x is the step value.
The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire
range of valid values.
e.g the following are all valid ranges
@ -2581,6 +2714,9 @@ namespace eval punk::lib {
(index 2 to 11)
..
(all indices)
.3.
(1st index and every 3rd index thereafter)
Common whitespace elements space,tab,newlines are ignored.
Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands,
e.g end-2 or 2+2.
@ -2670,20 +2806,19 @@ namespace eval punk::lib {
.-1. would represent end to base with step -1
If start is omitted and only the end is supplied:
The default step is 1 indicating ascension and the missing end is equivalent to 'end'
indexset_resolve 5 2..
-> 2 3 4
The default end is the base if the step is negative
indexset_resolve 5 2.-1.
-> 2 1 0
If end is omitted and onlthe start is supplied:
The default step is 1 indicating ascension and the missing start is equivalent to the base.
indexset_resolve 5 ..2
-> 0 1 2
The default start is 'end' if the step is negative
indexset_resolve 5 .-1.2
-> 4 3 2
If end is omitted and only the start is supplied:
The default step is 1 indicating ascension and the missing end is equivalent to 'end'
indexset_resolve 5 2..
-> 2 3 4
The default end is the base if the step is negative
indexset_resolve 5 2.-1.
-> 2 1 0
Like the tcl9 lseq command - a step (by) value of zero produces no results.
@ -2703,7 +2838,7 @@ namespace eval punk::lib {
indexset examples:
These assume the default 0-based indices (base == 0)
These assume the default 0-based indices (-base 0)
1,3..
output the index 1 (2nd item) followed by all from index 3 to the end.
@ -3604,7 +3739,7 @@ namespace eval punk::lib {
@id -id ::punk::lib::gcd
@cmd -name punk::lib::gcd\
-summary\
"Gretest common divisor of m and n."\
"Greatest common divisor of m and n."\
-help\
"Return the greatest common divisor of m and n.
Straight from Lars Hellström's math::numtheory library in Tcllib
@ -3643,12 +3778,22 @@ namespace eval punk::lib {
return $m
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lcm
@cmd -name punk::lib::lcm\
-summary\
"Lowest common multiple of m and n."\
-help\
"Return the lowest common multiple of m and n.
Straight from Lars Hellström's math::numtheory library in Tcllib"
@values -min 2 -max 2
m -type integer
n -type integer
}]
}
proc lcm {n m} {
#*** !doctools
#[call [fun gcd] [arg n] [arg m]]
#[para]Return the lowest common multiple of m and n
#[para]Straight from Lars Hellström's math::numtheory library in Tcllib
#[para]
set gcd [gcd $n $m]
return [expr {$n*$m/$gcd}]
}

6
src/modules/punk/path-999999.0a1.0.tm

@ -294,7 +294,8 @@ namespace eval punk::path {
}
} elseif {[lindex $parts 0] ne ""} {
#relpath a/b/c
set parts [linsert $parts 0 .]
#set parts [linsert $parts 0 .]
ledit parts -1 -1 .
set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path
@ -1091,7 +1092,8 @@ namespace eval punk::path {
# loc is: ref/sub = sub
while {$reference_len > 0} {
set location [linsert $location 0 ..]
#set location [linsert $location 0 ..]
ledit location -1 -1 ..
incr reference_len -1
}
set location [file join {*}$location]

3
src/modules/punk/repl-999999.0a1.0.tm

@ -1036,7 +1036,8 @@ namespace eval punk::repl::class {
# set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
# incr nextrow -1
#}
set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
#set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
ledit o_rendered_lines $cursor_row_idx $cursor_row_idx-1 ""
set o_cursor_col 1
}

12
src/modules/punk/safe-999999.0a1.0.tm

@ -922,14 +922,18 @@ tcl::namespace::eval punk::safe::system {
set where [lsearch -exact $access_path [info library]]
if {$where < 0} {
# not found, add it.
set access_path [linsert $access_path 0 [info library]]
#set access_path [linsert $access_path 0 [info library]]
ledit access_path -1 -1 [info library]
Log $child "tcl_library was not in auto_path,\
added it to child's access_path" NOTICE
} elseif {$where != 0} {
# not first, move it first
set access_path [linsert \
[lreplace $access_path $where $where] \
0 [info library]]
#set access_path [linsert \
# [lreplace $access_path $where $where] \
# 0 [info library]]
ledit access_path $where $where
ledit access_path -1 -1 [info library]
Log $child "tcl_libray was not in first in auto_path,\
moved it to front of child's access_path" NOTICE
}

18
src/modules/punkcheck-0.1.0.tm

@ -323,7 +323,8 @@ namespace eval punkcheck {
if {$isnew} {
lappend record_list $o_fileset_record
} else {
set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record]
#set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record]
ledit record_list $oldposition $oldposition-1 $o_fileset_record
}
if {$o_operation ne "QUERY"} {
punkcheck::save_records_to_file $record_list $punkcheck_file
@ -536,7 +537,8 @@ namespace eval punkcheck {
set existing_header_posn [dict get $resultinfo position]
if {$existing_header_posn == -1} {
set this_installer_record [punkcheck::recordlist::new_installer_record $o_name]
set o_record_list [linsert $o_record_list 0 $this_installer_record]
#set o_record_list [linsert $o_record_list 0 $this_installer_record]
ledit o_record_list -1 -1 $this_installer_record
} else {
set this_installer_record [dict get $resultinfo record]
}
@ -616,7 +618,8 @@ namespace eval punkcheck {
set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records]
set existing_header_posn [dict get $persistedinfo position]
if {$existing_header_posn == -1} {
set file_records [linsert $file_records 0 $this_installer_record]
#set file_records [linsert $file_records 0 $this_installer_record]
ledit file_records -1 -1 $this_installer_record
} else {
lset file_records $existing_header_posn $this_installer_record
}
@ -710,7 +713,8 @@ namespace eval punkcheck {
if {$existing_header_posn == -1} {
#not found - prepend
set record_list [linsert $record_list 0 $this_installer_record]
#set record_list [linsert $record_list 0 $this_installer_record]
ledit record_list -1 -1 $this_installer_record
} else {
#replace
lset record_list $existing_header_posn $this_installer_record
@ -791,7 +795,8 @@ namespace eval punkcheck {
if {$isnew} {
lappend record_list $file_record
} else {
set record_list [linsert $record_list[unset record_list] $oldposition $file_record]
#set record_list [linsert $record_list[unset record_list] $oldposition $file_record]
ledit record_list $oldposition $oldposition-1 $file_record
}
save_records_to_file $record_list $punkcheck_file
@ -1191,7 +1196,8 @@ namespace eval punkcheck {
# dst is: base/sub = sub
while {$baselen > 0} {
set dst [linsert $dst 0 ..]
#set dst [linsert $dst 0 ..]
ledit dst -1 -1 ..
incr baselen -1
}
set dst [file join {*}$dst]

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

@ -4480,7 +4480,8 @@ tcl::namespace::eval textblock {
set code_idx 3
foreach {pt code} [lrange $parts 2 end] {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts $code_idx+1 $base]
#set parts [linsert $parts $code_idx+1 $base]
ledit parts $code_idx+1 $code_idx $base
}
incr code_idx 2
}
@ -4504,12 +4505,14 @@ tcl::namespace::eval textblock {
#first pt & code
if {$pt ne ""} {
#leading plaintext
set parts [linsert $parts 0 $base]
#set parts [linsert $parts 0 $base]
ledit parts -1 -1 $base
incr offset
}
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts [expr {$code_idx+1+$offset}] $base]
#ledit parts [expr {$code_idx+1+$offset}] $code_idx+$offset $base
incr offset
}
incr code_idx 2
@ -5371,6 +5374,9 @@ tcl::namespace::eval textblock {
r-1 {
if {[lindex $line_chunks end] eq ""} {
set line_chunks [linsert $line_chunks end-2 $pad]
#breaks layout e.g subtables in: i i
#why?
#ledit line_chunks end-2 end-3 $pad
} else {
lappend line_chunks $pad
}
@ -5379,24 +5385,30 @@ tcl::namespace::eval textblock {
lappend line_chunks $pad
}
l-0 {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
l-1 {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
#set line_chunks [linsert $line_chunks 2 $pad]
ledit line_chunks 2 1 $pad
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
l-2 {
if {$lnum == 0} {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
#set line_chunks [linsert $line_chunks 2 $pad]
ledit line_chunks 2 1 $pad
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
}
@ -5466,14 +5478,17 @@ tcl::namespace::eval textblock {
#} else {
# set line_chunks [linsert $line_chunks 0 $pad]
#}
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
l-1 {
#set line_chunks [linsert $line_chunks 0 $pad]
set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks]
}
l-2 {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
}

148
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.2.tm

@ -25,17 +25,46 @@
namespace eval dictn {
namespace export {[a-z]*}
namespace ensemble create
namespace eval argdoc {
variable PUNKARGS
#non-colour SGR codes
set I "\x1b\[3m" ;# [a+ italic]
set NI "\x1b\[23m" ;# [a+ noitalic]
set B "\x1b\[1m" ;# [a+ bold]
set N "\x1b\[22m" ;# [a+ normal]
set T "\x1b\[1\;4m" ;# [a+ bold underline]
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline]
}
}
## ::dictn::append
#This can of course 'ruin' a nested dict if applied to the wrong element
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl:
# %set list {a b {c d}}
# %append list x
# a b {c d}x
# IOW - don't do that unless you really know that's what you want.
#
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::append
@cmd -name dictn::append\
-summary\
"Append a single string to the value at dict path."\
-help\
"Append a single string to the value at a given dictionary path.
This can of course 'ruin' a nested dict if applied to the wrong element
- i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl:
%set list {a b {c d}}
%append list x
a b {c d}x
IOW - don't do that unless you really know that's what you want.
Note than unlike dict append - only a single value is accepted for appending.
"
@values -min 2 -max 3
dictvar -type string
path -type list
value -type any -default "" -optional 1
}]
}
proc ::dictn::append {dictvar path {value {}}} {
if {[llength $path] == 1} {
uplevel 1 [list dict append $dictvar $path $value]
@ -43,7 +72,7 @@ proc ::dictn::append {dictvar path {value {}}} {
upvar 1 $dictvar dvar
::set str [dict get $dvar {*}$path]
append str $val
append str $value
dict set dvar {*}$path $str
}
}
@ -73,6 +102,25 @@ proc ::dictn::for {keyvalvars dictval path body} {
proc ::dictn::get {dictval {path {}}} {
return [dict get $dictval {*}$path]
}
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::getn
@cmd -name dictn::getn\
-summary\
"Get one or more paths in a dict simultaneously."\
-help\
""
@values -min 1 -max -1
dictvar -type string
path -type list -multiple 1
}]
}
proc ::dictn::getn {dictval args} {
if {![llength $args]} {
return [::tcl::dict::get $dictval]
}
lmap path $args {::tcl::dict::get $dictval {*}$path}
}
if {[info commands ::tcl::dict::getdef] ne ""} {
@ -85,10 +133,18 @@ if {[info commands ::tcl::dict::getdef] ne ""} {
return [dict getdef $dictval {*}$path $default]
}
proc ::dictn::incr {dictvar path {increment {}} } {
if {$increment eq ""} {
::set increment 1
proc ::dictn::incr {dictvar path {increment 1} } {
upvar 1 $dictvar dvar
if {[llength $path] == 1} {
return [::tcl::dict::incr dvar $path $increment]
}
if {[::tcl::info::exists dvar]} {
::set increment [expr {[::tcl::dict::getdef $dvar {*}$path 0] + $increment}]
}
return [::tcl::dict::set dvar {*}$path $increment]
}
#test - compare disassembly
proc ::dictn::incr2 {dictvar path {increment 1} } {
if {[llength $path] == 1} {
uplevel 1 [list dict incr $dictvar $path $increment]
} else {
@ -233,6 +289,33 @@ proc ::dictn::set {dictvar path newval} {
return [dict set dvar {*}$path $newval]
}
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::setn
@cmd -name dictn::setn\
-summary\
"Set one or more paths in a dict to value(s)"\
-help\
""
@values -min 3 -max -1
dictvar -type string
path_newval -type {path newval} -multiple 1
}]
}
proc ::dictn::setn {dictvar args} {
if {[llength $args] == 0} {
error "dictn::setn requires at least one <path> <newval> pair"
}
if {[llength $args] % 2 != 0} {
error "dictn::setn requires trailing <path> <newval> pairs"
}
upvar 1 $dictvar dvar
foreach {p v} $args {
::tcl::dict::set dvar {*}$p $v
}
return $dvar
}
proc ::dictn::size {dictval {path {}}} {
return [dict size [dict get $dictval {*}$path]]
}
@ -312,6 +395,46 @@ proc ::dictn::values {dictval {path {}} {glob {}}} {
}
}
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::with
@cmd -name dictn::with\
-summary\
"Execute script for each key at dict path."\
-help\
"Execute the Tcl script in body with the value for each key within the
given key-path mapped to either variables or keys in a specified array.
If the name of an array variable is not supplied for arrayvar,
dictn with behaves like dict with, except that it accepts a list
for the possibly nested key-path instead of separate arguments.
The subkeys of the dict at the given key-path will create variables
in the calling scope.
If an arrayvar is passed, an array of that name in the calling
scope will be populated with keys and values from the subkeys and
values of the dict at the given key-path."
@form -form standard
@values -min 3 -max 3
dictvar -type string
path -type list
body -type string
@form -form array
@values -min 4 -max 4
dictvar -type string
path -type list
arrayvar -type string -help\
"Name of array variable in which key values are
stored for the given dict path.
This prevents key values being used as variable
names in the calling scope, instead capturing them
as keys in the single specified array at the calling
scope."
body -type string
}]
}
# Standard form:
#'dictn with dictVariable path body'
#
@ -351,7 +474,10 @@ proc ::dictn::with {dictvar path args} {
::tcl::namespace::eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::dictn
}

241
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm

@ -751,6 +751,27 @@ namespace eval punk::lib {
# -- ---
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lswap
@cmd -name punk::lib::lswap\
-summary\
"Swap list values in-place"\
-help\
"Similar to struct::list swap, except it fully supports basic
list index expressions such as 7-2 end-1 etc.
struct::list swap doesn't support 'end' offsets, and only
sometimes appears to support basic expressions, depending on the
expression compared to the list length."
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
proc lswap {lvar a z} {
upvar $lvar l
set len [llength $l]
@ -955,42 +976,69 @@ namespace eval punk::lib {
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lzip
@cmd -name punk::lib::lzip\
-summary\
"zip any number of lists together."\
-help\
"Conceptually equivalent to converting a list of rows
to a list of columns.
The number of returned lists (columns) will be equal to
the length of the longest supplied list (row).
If lengths of supplied lists don't match, empty strings
will be inserted in the resulting lists.
e.g lzip {a b c d e} {1 2 3 4} {x y z}
-> {a 1 x} {b 2 y} {c 3 z} {d 4 {}} {3 {} {}}
"
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
proc lzip {args} {
switch -- [llength $args] {
0 {return {}}
1 {return [lindex $args 0]}
2 {return [lzip2lists {*}$args]}
3 {return [lzip3lists {*}$args]}
4 {return [lzip4lists {*}$args]}
5 {return [lzip5lists {*}$args]}
6 {return [lzip6lists {*}$args]}
7 {return [lzip7lists {*}$args]}
8 {return [lzip8lists {*}$args]}
9 {return [lzip9lists {*}$args]}
10 {return [lzip10lists {*}$args]}
2 {return [::punk::lib::system::lzip2lists {*}$args]}
3 {return [::punk::lib::system::lzip3lists {*}$args]}
4 {return [::punk::lib::system::lzip4lists {*}$args]}
5 {return [::punk::lib::system::lzip5lists {*}$args]}
6 {return [::punk::lib::system::lzip6lists {*}$args]}
7 {return [::punk::lib::system::lzip7lists {*}$args]}
8 {return [::punk::lib::system::lzip8lists {*}$args]}
9 {return [::punk::lib::system::lzip9lists {*}$args]}
10 {return [::punk::lib::system::lzip10lists {*}$args]}
11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 {
set n [llength $args]
if {[info commands ::punk::lib::lzip${n}lists] eq ""} {
puts "calling ::punk::lib::Build_lzipn $n"
::punk::lib::Build_lzipn $n
if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} {
#puts "calling ::punk::lib::system::Build_lzipn $n"
::punk::lib::system::Build_lzipn $n
}
return [lzip${n}lists {*}$args]
return [::punk::lib::system::lzip${n}lists {*}$args]
}
default {
if {[llength $args] < 4000} {
set n [llength $args]
if {[info commands ::punk::lib::lzip${n}lists] eq ""} {
puts "calling ::punk::lib::Build_lzipn $n"
::punk::lib::Build_lzipn $n
if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} {
#puts "calling ::punk::lib::system::Build_lzipn $n"
::punk::lib::system::Build_lzipn $n
}
return [lzip${n}lists {*}$args]
return [::punk::lib::system::lzip${n}lists {*}$args]
} else {
return [lzipn {*}$args]
return [::punk::lib::lzipn {*}$args]
}
}
}
}
namespace eval system {
proc Build_lzipn {n} {
set arglist [list]
#use punk::lib::range which defers to lseq if available
@ -1005,10 +1053,10 @@ namespace eval punk::lib {
append body "\$[lindex $vars $i] "
}
append body "\}" \n
puts "proc punk::lib::lzip${n}lists {$arglist} \{"
puts "$body"
puts "\}"
proc ::punk::lib::lzip${n}lists $arglist $body
#puts "proc punk::lib::system::lzip${n}lists {$arglist} \{"
#puts "$body"
#puts "\}"
proc ::punk::lib::system::lzip${n}lists $arglist $body
}
#fastest is to know the number of lists to be zipped
@ -1053,6 +1101,7 @@ namespace eval punk::lib {
#2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?)
proc lzipn_tcl8 {args} {
#For tcl pre 9 (without lsearch -stride)
#wiki - courtesy JAL
set list_l $args
set zip_l []
@ -1068,6 +1117,7 @@ namespace eval punk::lib {
return $zip_l
}
proc lzipn_tcl9a {args} {
#For Tcl 9+ (with lsearch -stride)
#compared to wiki version
#comparable for lists len <3 or number of args < 3
#approx 2x faster for large lists or more lists
@ -1121,15 +1171,38 @@ namespace eval punk::lib {
}
return $zip_l
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lzipn
@cmd -name punk::lib::lzipn\
-summary\
"zip any number of lists together (unoptimised)."\
-help\
"Conceptually equivalent to converting a list of rows
to a list of columns.
See lzip which provides the same functionality but with
optimisations depending on the number of supplied lists.
"
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
#keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible
if {![package vsatisfies [package present Tcl] 9.0-] || [dict get [punk::lib::check::has_tclbug_lsearch_strideallinline] bug]} {
#-stride either not available - or has bug preventing use of main algorithm below
proc lzipn {args} [info body ::punk::lib::lzipn_tcl8]
proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl8]
} else {
proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a]
proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl9a]
}
namespace import ::punk::args::lib::tstr
namespace eval argdoc {
@ -2291,13 +2364,31 @@ namespace eval punk::lib {
proc is_list_all_ni_list2 {a b} $body
}
#somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist
#struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on,
# especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg)
proc ldiff {fromlist removeitems} {
if {[llength $removeitems] == 0} {return $fromlist}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::ldiff
@cmd -name punk::lib::ldiff\
-summary\
"Difference consisting of items with removeitems removed."\
-help\
"Somewhat like struct::set difference, but order preserving, and doesn't
treat as a 'set' so preserves any duplicates in items.
struct::set difference may happen to preserve ordering when items are
integers, but order can't be relied on, especially as struct::set has
2 differening implementations (tcl vs critcl) which return results with
different ordering to each other and different deduping behaviour in
some cases (e.g when 2nd arg is empty)"
@values -min 2 -max 2
items -type list
removeitems -type list
}]
}
proc ldiff {items removeitems} {
if {[llength $removeitems] == 0} {return $items}
set result {}
foreach item $fromlist {
foreach item $items {
if {$item ni $removeitems} {
lappend result $item
}
@ -2361,6 +2452,28 @@ namespace eval punk::lib {
return [array names tmp]
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lunique_unordered
@cmd -name punk::lib::lunique_unordered\
-summary\
"unique values in list"\
-help\
"Return unique values in provided list.
This removes duplicates but *may* rearrange the
order of the returned elements compared to the
original list.
When struct::set is available this will be used
for the implementation, as it can be *slightly*
faster if acceleration is present. When struct::set
is not available it will fallback to lunique and
provide the same functionality with order preserved."
@values -min 1 -max 1
list -type list
}]
}
#default/fallback implementation
proc lunique_unordered {list} {
lunique $list
@ -2371,13 +2484,33 @@ namespace eval punk::lib {
struct::set union $list {}
}
} else {
puts stderr "WARNING: struct::set union <list> <emptylist> no longer dedupes!"
#struct::set union operates on a 'set' - so this probably won't change, and hopefully is
#consistent across unacelerated versions and those implemented in accelerators,
#but if it ever does change - be a little noisy about it.
puts stderr "punk::lib WARNING: struct::set union <list> <emptylist> no longer dedupes!"
#we could also test a sequence of: struct::set add
}
}
#order-preserving
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lunique
@cmd -name punk::lib::lunique\
-summary\
"Order-preserving unique values in list"\
-help\
"Return unique values in provided list.
This removes duplicates whilst preserving the
original order of the provided list.
When struct::set is available with acceleration,
lunique_unordered may be slightly faster."
@values -min 1 -max 1
list -type list
}]
}
proc lunique {list} {
set new {}
foreach item $list {
@ -2569,7 +2702,7 @@ namespace eval punk::lib {
To validate if an indexset is strictly within range, both the length of the data and the base would
need to be considered.
The normal 'range' specifier is ..
The normal 'range' specifier is .. but can be of the form .x. where x is the step value.
The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire
range of valid values.
e.g the following are all valid ranges
@ -2581,6 +2714,9 @@ namespace eval punk::lib {
(index 2 to 11)
..
(all indices)
.3.
(1st index and every 3rd index thereafter)
Common whitespace elements space,tab,newlines are ignored.
Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands,
e.g end-2 or 2+2.
@ -2670,20 +2806,19 @@ namespace eval punk::lib {
.-1. would represent end to base with step -1
If start is omitted and only the end is supplied:
The default step is 1 indicating ascension and the missing end is equivalent to 'end'
indexset_resolve 5 2..
-> 2 3 4
The default end is the base if the step is negative
indexset_resolve 5 2.-1.
-> 2 1 0
If end is omitted and onlthe start is supplied:
The default step is 1 indicating ascension and the missing start is equivalent to the base.
indexset_resolve 5 ..2
-> 0 1 2
The default start is 'end' if the step is negative
indexset_resolve 5 .-1.2
-> 4 3 2
If end is omitted and only the start is supplied:
The default step is 1 indicating ascension and the missing end is equivalent to 'end'
indexset_resolve 5 2..
-> 2 3 4
The default end is the base if the step is negative
indexset_resolve 5 2.-1.
-> 2 1 0
Like the tcl9 lseq command - a step (by) value of zero produces no results.
@ -2703,7 +2838,7 @@ namespace eval punk::lib {
indexset examples:
These assume the default 0-based indices (base == 0)
These assume the default 0-based indices (-base 0)
1,3..
output the index 1 (2nd item) followed by all from index 3 to the end.
@ -3604,7 +3739,7 @@ namespace eval punk::lib {
@id -id ::punk::lib::gcd
@cmd -name punk::lib::gcd\
-summary\
"Gretest common divisor of m and n."\
"Greatest common divisor of m and n."\
-help\
"Return the greatest common divisor of m and n.
Straight from Lars Hellström's math::numtheory library in Tcllib
@ -3643,12 +3778,22 @@ namespace eval punk::lib {
return $m
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lcm
@cmd -name punk::lib::lcm\
-summary\
"Lowest common multiple of m and n."\
-help\
"Return the lowest common multiple of m and n.
Straight from Lars Hellström's math::numtheory library in Tcllib"
@values -min 2 -max 2
m -type integer
n -type integer
}]
}
proc lcm {n m} {
#*** !doctools
#[call [fun gcd] [arg n] [arg m]]
#[para]Return the lowest common multiple of m and n
#[para]Straight from Lars Hellström's math::numtheory library in Tcllib
#[para]
set gcd [gcd $n $m]
return [expr {$n*$m/$gcd}]
}

3
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm

@ -1036,7 +1036,8 @@ namespace eval punk::repl::class {
# set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
# incr nextrow -1
#}
set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
#set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
ledit o_rendered_lines $cursor_row_idx $cursor_row_idx-1 ""
set o_cursor_col 1
}

18
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm

@ -323,7 +323,8 @@ namespace eval punkcheck {
if {$isnew} {
lappend record_list $o_fileset_record
} else {
set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record]
#set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record]
ledit record_list $oldposition $oldposition-1 $o_fileset_record
}
if {$o_operation ne "QUERY"} {
punkcheck::save_records_to_file $record_list $punkcheck_file
@ -536,7 +537,8 @@ namespace eval punkcheck {
set existing_header_posn [dict get $resultinfo position]
if {$existing_header_posn == -1} {
set this_installer_record [punkcheck::recordlist::new_installer_record $o_name]
set o_record_list [linsert $o_record_list 0 $this_installer_record]
#set o_record_list [linsert $o_record_list 0 $this_installer_record]
ledit o_record_list -1 -1 $this_installer_record
} else {
set this_installer_record [dict get $resultinfo record]
}
@ -616,7 +618,8 @@ namespace eval punkcheck {
set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records]
set existing_header_posn [dict get $persistedinfo position]
if {$existing_header_posn == -1} {
set file_records [linsert $file_records 0 $this_installer_record]
#set file_records [linsert $file_records 0 $this_installer_record]
ledit file_records -1 -1 $this_installer_record
} else {
lset file_records $existing_header_posn $this_installer_record
}
@ -710,7 +713,8 @@ namespace eval punkcheck {
if {$existing_header_posn == -1} {
#not found - prepend
set record_list [linsert $record_list 0 $this_installer_record]
#set record_list [linsert $record_list 0 $this_installer_record]
ledit record_list -1 -1 $this_installer_record
} else {
#replace
lset record_list $existing_header_posn $this_installer_record
@ -791,7 +795,8 @@ namespace eval punkcheck {
if {$isnew} {
lappend record_list $file_record
} else {
set record_list [linsert $record_list[unset record_list] $oldposition $file_record]
#set record_list [linsert $record_list[unset record_list] $oldposition $file_record]
ledit record_list $oldposition $oldposition-1 $file_record
}
save_records_to_file $record_list $punkcheck_file
@ -1191,7 +1196,8 @@ namespace eval punkcheck {
# dst is: base/sub = sub
while {$baselen > 0} {
set dst [linsert $dst 0 ..]
#set dst [linsert $dst 0 ..]
ledit dst -1 -1 ..
incr baselen -1
}
set dst [file join {*}$dst]

32
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm

@ -4480,7 +4480,8 @@ tcl::namespace::eval textblock {
set code_idx 3
foreach {pt code} [lrange $parts 2 end] {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts $code_idx+1 $base]
#set parts [linsert $parts $code_idx+1 $base]
ledit parts $code_idx+1 $code_idx $base
}
incr code_idx 2
}
@ -4504,12 +4505,14 @@ tcl::namespace::eval textblock {
#first pt & code
if {$pt ne ""} {
#leading plaintext
set parts [linsert $parts 0 $base]
#set parts [linsert $parts 0 $base]
ledit parts -1 -1 $base
incr offset
}
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts [expr {$code_idx+1+$offset}] $base]
#ledit parts [expr {$code_idx+1+$offset}] $code_idx+$offset $base
incr offset
}
incr code_idx 2
@ -5371,6 +5374,9 @@ tcl::namespace::eval textblock {
r-1 {
if {[lindex $line_chunks end] eq ""} {
set line_chunks [linsert $line_chunks end-2 $pad]
#breaks layout e.g subtables in: i i
#why?
#ledit line_chunks end-2 end-3 $pad
} else {
lappend line_chunks $pad
}
@ -5379,13 +5385,16 @@ tcl::namespace::eval textblock {
lappend line_chunks $pad
}
l-0 {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
l-1 {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
#set line_chunks [linsert $line_chunks 2 $pad]
ledit line_chunks 2 1 $pad
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
l-2 {
@ -5393,10 +5402,12 @@ tcl::namespace::eval textblock {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
}
@ -5466,14 +5477,17 @@ tcl::namespace::eval textblock {
#} else {
# set line_chunks [linsert $line_chunks 0 $pad]
#}
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
l-1 {
#set line_chunks [linsert $line_chunks 0 $pad]
set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks]
}
l-2 {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
}

148
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/dictn-0.1.2.tm

@ -25,17 +25,46 @@
namespace eval dictn {
namespace export {[a-z]*}
namespace ensemble create
namespace eval argdoc {
variable PUNKARGS
#non-colour SGR codes
set I "\x1b\[3m" ;# [a+ italic]
set NI "\x1b\[23m" ;# [a+ noitalic]
set B "\x1b\[1m" ;# [a+ bold]
set N "\x1b\[22m" ;# [a+ normal]
set T "\x1b\[1\;4m" ;# [a+ bold underline]
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline]
}
}
## ::dictn::append
#This can of course 'ruin' a nested dict if applied to the wrong element
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl:
# %set list {a b {c d}}
# %append list x
# a b {c d}x
# IOW - don't do that unless you really know that's what you want.
#
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::append
@cmd -name dictn::append\
-summary\
"Append a single string to the value at dict path."\
-help\
"Append a single string to the value at a given dictionary path.
This can of course 'ruin' a nested dict if applied to the wrong element
- i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl:
%set list {a b {c d}}
%append list x
a b {c d}x
IOW - don't do that unless you really know that's what you want.
Note than unlike dict append - only a single value is accepted for appending.
"
@values -min 2 -max 3
dictvar -type string
path -type list
value -type any -default "" -optional 1
}]
}
proc ::dictn::append {dictvar path {value {}}} {
if {[llength $path] == 1} {
uplevel 1 [list dict append $dictvar $path $value]
@ -43,7 +72,7 @@ proc ::dictn::append {dictvar path {value {}}} {
upvar 1 $dictvar dvar
::set str [dict get $dvar {*}$path]
append str $val
append str $value
dict set dvar {*}$path $str
}
}
@ -73,6 +102,25 @@ proc ::dictn::for {keyvalvars dictval path body} {
proc ::dictn::get {dictval {path {}}} {
return [dict get $dictval {*}$path]
}
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::getn
@cmd -name dictn::getn\
-summary\
"Get one or more paths in a dict simultaneously."\
-help\
""
@values -min 1 -max -1
dictvar -type string
path -type list -multiple 1
}]
}
proc ::dictn::getn {dictval args} {
if {![llength $args]} {
return [::tcl::dict::get $dictval]
}
lmap path $args {::tcl::dict::get $dictval {*}$path}
}
if {[info commands ::tcl::dict::getdef] ne ""} {
@ -85,10 +133,18 @@ if {[info commands ::tcl::dict::getdef] ne ""} {
return [dict getdef $dictval {*}$path $default]
}
proc ::dictn::incr {dictvar path {increment {}} } {
if {$increment eq ""} {
::set increment 1
proc ::dictn::incr {dictvar path {increment 1} } {
upvar 1 $dictvar dvar
if {[llength $path] == 1} {
return [::tcl::dict::incr dvar $path $increment]
}
if {[::tcl::info::exists dvar]} {
::set increment [expr {[::tcl::dict::getdef $dvar {*}$path 0] + $increment}]
}
return [::tcl::dict::set dvar {*}$path $increment]
}
#test - compare disassembly
proc ::dictn::incr2 {dictvar path {increment 1} } {
if {[llength $path] == 1} {
uplevel 1 [list dict incr $dictvar $path $increment]
} else {
@ -233,6 +289,33 @@ proc ::dictn::set {dictvar path newval} {
return [dict set dvar {*}$path $newval]
}
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::setn
@cmd -name dictn::setn\
-summary\
"Set one or more paths in a dict to value(s)"\
-help\
""
@values -min 3 -max -1
dictvar -type string
path_newval -type {path newval} -multiple 1
}]
}
proc ::dictn::setn {dictvar args} {
if {[llength $args] == 0} {
error "dictn::setn requires at least one <path> <newval> pair"
}
if {[llength $args] % 2 != 0} {
error "dictn::setn requires trailing <path> <newval> pairs"
}
upvar 1 $dictvar dvar
foreach {p v} $args {
::tcl::dict::set dvar {*}$p $v
}
return $dvar
}
proc ::dictn::size {dictval {path {}}} {
return [dict size [dict get $dictval {*}$path]]
}
@ -312,6 +395,46 @@ proc ::dictn::values {dictval {path {}} {glob {}}} {
}
}
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::with
@cmd -name dictn::with\
-summary\
"Execute script for each key at dict path."\
-help\
"Execute the Tcl script in body with the value for each key within the
given key-path mapped to either variables or keys in a specified array.
If the name of an array variable is not supplied for arrayvar,
dictn with behaves like dict with, except that it accepts a list
for the possibly nested key-path instead of separate arguments.
The subkeys of the dict at the given key-path will create variables
in the calling scope.
If an arrayvar is passed, an array of that name in the calling
scope will be populated with keys and values from the subkeys and
values of the dict at the given key-path."
@form -form standard
@values -min 3 -max 3
dictvar -type string
path -type list
body -type string
@form -form array
@values -min 4 -max 4
dictvar -type string
path -type list
arrayvar -type string -help\
"Name of array variable in which key values are
stored for the given dict path.
This prevents key values being used as variable
names in the calling scope, instead capturing them
as keys in the single specified array at the calling
scope."
body -type string
}]
}
# Standard form:
#'dictn with dictVariable path body'
#
@ -351,7 +474,10 @@ proc ::dictn::with {dictvar path args} {
::tcl::namespace::eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::dictn
}

241
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm

@ -751,6 +751,27 @@ namespace eval punk::lib {
# -- ---
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lswap
@cmd -name punk::lib::lswap\
-summary\
"Swap list values in-place"\
-help\
"Similar to struct::list swap, except it fully supports basic
list index expressions such as 7-2 end-1 etc.
struct::list swap doesn't support 'end' offsets, and only
sometimes appears to support basic expressions, depending on the
expression compared to the list length."
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
proc lswap {lvar a z} {
upvar $lvar l
set len [llength $l]
@ -955,42 +976,69 @@ namespace eval punk::lib {
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lzip
@cmd -name punk::lib::lzip\
-summary\
"zip any number of lists together."\
-help\
"Conceptually equivalent to converting a list of rows
to a list of columns.
The number of returned lists (columns) will be equal to
the length of the longest supplied list (row).
If lengths of supplied lists don't match, empty strings
will be inserted in the resulting lists.
e.g lzip {a b c d e} {1 2 3 4} {x y z}
-> {a 1 x} {b 2 y} {c 3 z} {d 4 {}} {3 {} {}}
"
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
proc lzip {args} {
switch -- [llength $args] {
0 {return {}}
1 {return [lindex $args 0]}
2 {return [lzip2lists {*}$args]}
3 {return [lzip3lists {*}$args]}
4 {return [lzip4lists {*}$args]}
5 {return [lzip5lists {*}$args]}
6 {return [lzip6lists {*}$args]}
7 {return [lzip7lists {*}$args]}
8 {return [lzip8lists {*}$args]}
9 {return [lzip9lists {*}$args]}
10 {return [lzip10lists {*}$args]}
2 {return [::punk::lib::system::lzip2lists {*}$args]}
3 {return [::punk::lib::system::lzip3lists {*}$args]}
4 {return [::punk::lib::system::lzip4lists {*}$args]}
5 {return [::punk::lib::system::lzip5lists {*}$args]}
6 {return [::punk::lib::system::lzip6lists {*}$args]}
7 {return [::punk::lib::system::lzip7lists {*}$args]}
8 {return [::punk::lib::system::lzip8lists {*}$args]}
9 {return [::punk::lib::system::lzip9lists {*}$args]}
10 {return [::punk::lib::system::lzip10lists {*}$args]}
11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 {
set n [llength $args]
if {[info commands ::punk::lib::lzip${n}lists] eq ""} {
puts "calling ::punk::lib::Build_lzipn $n"
::punk::lib::Build_lzipn $n
if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} {
#puts "calling ::punk::lib::system::Build_lzipn $n"
::punk::lib::system::Build_lzipn $n
}
return [lzip${n}lists {*}$args]
return [::punk::lib::system::lzip${n}lists {*}$args]
}
default {
if {[llength $args] < 4000} {
set n [llength $args]
if {[info commands ::punk::lib::lzip${n}lists] eq ""} {
puts "calling ::punk::lib::Build_lzipn $n"
::punk::lib::Build_lzipn $n
if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} {
#puts "calling ::punk::lib::system::Build_lzipn $n"
::punk::lib::system::Build_lzipn $n
}
return [lzip${n}lists {*}$args]
return [::punk::lib::system::lzip${n}lists {*}$args]
} else {
return [lzipn {*}$args]
return [::punk::lib::lzipn {*}$args]
}
}
}
}
namespace eval system {
proc Build_lzipn {n} {
set arglist [list]
#use punk::lib::range which defers to lseq if available
@ -1005,10 +1053,10 @@ namespace eval punk::lib {
append body "\$[lindex $vars $i] "
}
append body "\}" \n
puts "proc punk::lib::lzip${n}lists {$arglist} \{"
puts "$body"
puts "\}"
proc ::punk::lib::lzip${n}lists $arglist $body
#puts "proc punk::lib::system::lzip${n}lists {$arglist} \{"
#puts "$body"
#puts "\}"
proc ::punk::lib::system::lzip${n}lists $arglist $body
}
#fastest is to know the number of lists to be zipped
@ -1053,6 +1101,7 @@ namespace eval punk::lib {
#2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?)
proc lzipn_tcl8 {args} {
#For tcl pre 9 (without lsearch -stride)
#wiki - courtesy JAL
set list_l $args
set zip_l []
@ -1068,6 +1117,7 @@ namespace eval punk::lib {
return $zip_l
}
proc lzipn_tcl9a {args} {
#For Tcl 9+ (with lsearch -stride)
#compared to wiki version
#comparable for lists len <3 or number of args < 3
#approx 2x faster for large lists or more lists
@ -1121,15 +1171,38 @@ namespace eval punk::lib {
}
return $zip_l
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lzipn
@cmd -name punk::lib::lzipn\
-summary\
"zip any number of lists together (unoptimised)."\
-help\
"Conceptually equivalent to converting a list of rows
to a list of columns.
See lzip which provides the same functionality but with
optimisations depending on the number of supplied lists.
"
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
#keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible
if {![package vsatisfies [package present Tcl] 9.0-] || [dict get [punk::lib::check::has_tclbug_lsearch_strideallinline] bug]} {
#-stride either not available - or has bug preventing use of main algorithm below
proc lzipn {args} [info body ::punk::lib::lzipn_tcl8]
proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl8]
} else {
proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a]
proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl9a]
}
namespace import ::punk::args::lib::tstr
namespace eval argdoc {
@ -2291,13 +2364,31 @@ namespace eval punk::lib {
proc is_list_all_ni_list2 {a b} $body
}
#somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist
#struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on,
# especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg)
proc ldiff {fromlist removeitems} {
if {[llength $removeitems] == 0} {return $fromlist}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::ldiff
@cmd -name punk::lib::ldiff\
-summary\
"Difference consisting of items with removeitems removed."\
-help\
"Somewhat like struct::set difference, but order preserving, and doesn't
treat as a 'set' so preserves any duplicates in items.
struct::set difference may happen to preserve ordering when items are
integers, but order can't be relied on, especially as struct::set has
2 differening implementations (tcl vs critcl) which return results with
different ordering to each other and different deduping behaviour in
some cases (e.g when 2nd arg is empty)"
@values -min 2 -max 2
items -type list
removeitems -type list
}]
}
proc ldiff {items removeitems} {
if {[llength $removeitems] == 0} {return $items}
set result {}
foreach item $fromlist {
foreach item $items {
if {$item ni $removeitems} {
lappend result $item
}
@ -2361,6 +2452,28 @@ namespace eval punk::lib {
return [array names tmp]
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lunique_unordered
@cmd -name punk::lib::lunique_unordered\
-summary\
"unique values in list"\
-help\
"Return unique values in provided list.
This removes duplicates but *may* rearrange the
order of the returned elements compared to the
original list.
When struct::set is available this will be used
for the implementation, as it can be *slightly*
faster if acceleration is present. When struct::set
is not available it will fallback to lunique and
provide the same functionality with order preserved."
@values -min 1 -max 1
list -type list
}]
}
#default/fallback implementation
proc lunique_unordered {list} {
lunique $list
@ -2371,13 +2484,33 @@ namespace eval punk::lib {
struct::set union $list {}
}
} else {
puts stderr "WARNING: struct::set union <list> <emptylist> no longer dedupes!"
#struct::set union operates on a 'set' - so this probably won't change, and hopefully is
#consistent across unacelerated versions and those implemented in accelerators,
#but if it ever does change - be a little noisy about it.
puts stderr "punk::lib WARNING: struct::set union <list> <emptylist> no longer dedupes!"
#we could also test a sequence of: struct::set add
}
}
#order-preserving
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lunique
@cmd -name punk::lib::lunique\
-summary\
"Order-preserving unique values in list"\
-help\
"Return unique values in provided list.
This removes duplicates whilst preserving the
original order of the provided list.
When struct::set is available with acceleration,
lunique_unordered may be slightly faster."
@values -min 1 -max 1
list -type list
}]
}
proc lunique {list} {
set new {}
foreach item $list {
@ -2569,7 +2702,7 @@ namespace eval punk::lib {
To validate if an indexset is strictly within range, both the length of the data and the base would
need to be considered.
The normal 'range' specifier is ..
The normal 'range' specifier is .. but can be of the form .x. where x is the step value.
The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire
range of valid values.
e.g the following are all valid ranges
@ -2581,6 +2714,9 @@ namespace eval punk::lib {
(index 2 to 11)
..
(all indices)
.3.
(1st index and every 3rd index thereafter)
Common whitespace elements space,tab,newlines are ignored.
Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands,
e.g end-2 or 2+2.
@ -2670,20 +2806,19 @@ namespace eval punk::lib {
.-1. would represent end to base with step -1
If start is omitted and only the end is supplied:
The default step is 1 indicating ascension and the missing end is equivalent to 'end'
indexset_resolve 5 2..
-> 2 3 4
The default end is the base if the step is negative
indexset_resolve 5 2.-1.
-> 2 1 0
If end is omitted and onlthe start is supplied:
The default step is 1 indicating ascension and the missing start is equivalent to the base.
indexset_resolve 5 ..2
-> 0 1 2
The default start is 'end' if the step is negative
indexset_resolve 5 .-1.2
-> 4 3 2
If end is omitted and only the start is supplied:
The default step is 1 indicating ascension and the missing end is equivalent to 'end'
indexset_resolve 5 2..
-> 2 3 4
The default end is the base if the step is negative
indexset_resolve 5 2.-1.
-> 2 1 0
Like the tcl9 lseq command - a step (by) value of zero produces no results.
@ -2703,7 +2838,7 @@ namespace eval punk::lib {
indexset examples:
These assume the default 0-based indices (base == 0)
These assume the default 0-based indices (-base 0)
1,3..
output the index 1 (2nd item) followed by all from index 3 to the end.
@ -3604,7 +3739,7 @@ namespace eval punk::lib {
@id -id ::punk::lib::gcd
@cmd -name punk::lib::gcd\
-summary\
"Gretest common divisor of m and n."\
"Greatest common divisor of m and n."\
-help\
"Return the greatest common divisor of m and n.
Straight from Lars Hellström's math::numtheory library in Tcllib
@ -3643,12 +3778,22 @@ namespace eval punk::lib {
return $m
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lcm
@cmd -name punk::lib::lcm\
-summary\
"Lowest common multiple of m and n."\
-help\
"Return the lowest common multiple of m and n.
Straight from Lars Hellström's math::numtheory library in Tcllib"
@values -min 2 -max 2
m -type integer
n -type integer
}]
}
proc lcm {n m} {
#*** !doctools
#[call [fun gcd] [arg n] [arg m]]
#[para]Return the lowest common multiple of m and n
#[para]Straight from Lars Hellström's math::numtheory library in Tcllib
#[para]
set gcd [gcd $n $m]
return [expr {$n*$m/$gcd}]
}

3
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm

@ -1036,7 +1036,8 @@ namespace eval punk::repl::class {
# set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
# incr nextrow -1
#}
set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
#set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
ledit o_rendered_lines $cursor_row_idx $cursor_row_idx-1 ""
set o_cursor_col 1
}

18
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm

@ -323,7 +323,8 @@ namespace eval punkcheck {
if {$isnew} {
lappend record_list $o_fileset_record
} else {
set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record]
#set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record]
ledit record_list $oldposition $oldposition-1 $o_fileset_record
}
if {$o_operation ne "QUERY"} {
punkcheck::save_records_to_file $record_list $punkcheck_file
@ -536,7 +537,8 @@ namespace eval punkcheck {
set existing_header_posn [dict get $resultinfo position]
if {$existing_header_posn == -1} {
set this_installer_record [punkcheck::recordlist::new_installer_record $o_name]
set o_record_list [linsert $o_record_list 0 $this_installer_record]
#set o_record_list [linsert $o_record_list 0 $this_installer_record]
ledit o_record_list -1 -1 $this_installer_record
} else {
set this_installer_record [dict get $resultinfo record]
}
@ -616,7 +618,8 @@ namespace eval punkcheck {
set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records]
set existing_header_posn [dict get $persistedinfo position]
if {$existing_header_posn == -1} {
set file_records [linsert $file_records 0 $this_installer_record]
#set file_records [linsert $file_records 0 $this_installer_record]
ledit file_records -1 -1 $this_installer_record
} else {
lset file_records $existing_header_posn $this_installer_record
}
@ -710,7 +713,8 @@ namespace eval punkcheck {
if {$existing_header_posn == -1} {
#not found - prepend
set record_list [linsert $record_list 0 $this_installer_record]
#set record_list [linsert $record_list 0 $this_installer_record]
ledit record_list -1 -1 $this_installer_record
} else {
#replace
lset record_list $existing_header_posn $this_installer_record
@ -791,7 +795,8 @@ namespace eval punkcheck {
if {$isnew} {
lappend record_list $file_record
} else {
set record_list [linsert $record_list[unset record_list] $oldposition $file_record]
#set record_list [linsert $record_list[unset record_list] $oldposition $file_record]
ledit record_list $oldposition $oldposition-1 $file_record
}
save_records_to_file $record_list $punkcheck_file
@ -1191,7 +1196,8 @@ namespace eval punkcheck {
# dst is: base/sub = sub
while {$baselen > 0} {
set dst [linsert $dst 0 ..]
#set dst [linsert $dst 0 ..]
ledit dst -1 -1 ..
incr baselen -1
}
set dst [file join {*}$dst]

32
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm

@ -4480,7 +4480,8 @@ tcl::namespace::eval textblock {
set code_idx 3
foreach {pt code} [lrange $parts 2 end] {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts $code_idx+1 $base]
#set parts [linsert $parts $code_idx+1 $base]
ledit parts $code_idx+1 $code_idx $base
}
incr code_idx 2
}
@ -4504,12 +4505,14 @@ tcl::namespace::eval textblock {
#first pt & code
if {$pt ne ""} {
#leading plaintext
set parts [linsert $parts 0 $base]
#set parts [linsert $parts 0 $base]
ledit parts -1 -1 $base
incr offset
}
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts [expr {$code_idx+1+$offset}] $base]
#ledit parts [expr {$code_idx+1+$offset}] $code_idx+$offset $base
incr offset
}
incr code_idx 2
@ -5371,6 +5374,9 @@ tcl::namespace::eval textblock {
r-1 {
if {[lindex $line_chunks end] eq ""} {
set line_chunks [linsert $line_chunks end-2 $pad]
#breaks layout e.g subtables in: i i
#why?
#ledit line_chunks end-2 end-3 $pad
} else {
lappend line_chunks $pad
}
@ -5379,13 +5385,16 @@ tcl::namespace::eval textblock {
lappend line_chunks $pad
}
l-0 {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
l-1 {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
#set line_chunks [linsert $line_chunks 2 $pad]
ledit line_chunks 2 1 $pad
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
l-2 {
@ -5393,10 +5402,12 @@ tcl::namespace::eval textblock {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
}
@ -5466,14 +5477,17 @@ tcl::namespace::eval textblock {
#} else {
# set line_chunks [linsert $line_chunks 0 $pad]
#}
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
l-1 {
#set line_chunks [linsert $line_chunks 0 $pad]
set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks]
}
l-2 {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
}

148
src/vfs/_vfscommon.vfs/modules/dictn-0.1.2.tm

@ -25,17 +25,46 @@
namespace eval dictn {
namespace export {[a-z]*}
namespace ensemble create
namespace eval argdoc {
variable PUNKARGS
#non-colour SGR codes
set I "\x1b\[3m" ;# [a+ italic]
set NI "\x1b\[23m" ;# [a+ noitalic]
set B "\x1b\[1m" ;# [a+ bold]
set N "\x1b\[22m" ;# [a+ normal]
set T "\x1b\[1\;4m" ;# [a+ bold underline]
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline]
}
}
## ::dictn::append
#This can of course 'ruin' a nested dict if applied to the wrong element
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl:
# %set list {a b {c d}}
# %append list x
# a b {c d}x
# IOW - don't do that unless you really know that's what you want.
#
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::append
@cmd -name dictn::append\
-summary\
"Append a single string to the value at dict path."\
-help\
"Append a single string to the value at a given dictionary path.
This can of course 'ruin' a nested dict if applied to the wrong element
- i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl:
%set list {a b {c d}}
%append list x
a b {c d}x
IOW - don't do that unless you really know that's what you want.
Note than unlike dict append - only a single value is accepted for appending.
"
@values -min 2 -max 3
dictvar -type string
path -type list
value -type any -default "" -optional 1
}]
}
proc ::dictn::append {dictvar path {value {}}} {
if {[llength $path] == 1} {
uplevel 1 [list dict append $dictvar $path $value]
@ -43,7 +72,7 @@ proc ::dictn::append {dictvar path {value {}}} {
upvar 1 $dictvar dvar
::set str [dict get $dvar {*}$path]
append str $val
append str $value
dict set dvar {*}$path $str
}
}
@ -73,6 +102,25 @@ proc ::dictn::for {keyvalvars dictval path body} {
proc ::dictn::get {dictval {path {}}} {
return [dict get $dictval {*}$path]
}
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::getn
@cmd -name dictn::getn\
-summary\
"Get one or more paths in a dict simultaneously."\
-help\
""
@values -min 1 -max -1
dictvar -type string
path -type list -multiple 1
}]
}
proc ::dictn::getn {dictval args} {
if {![llength $args]} {
return [::tcl::dict::get $dictval]
}
lmap path $args {::tcl::dict::get $dictval {*}$path}
}
if {[info commands ::tcl::dict::getdef] ne ""} {
@ -85,10 +133,18 @@ if {[info commands ::tcl::dict::getdef] ne ""} {
return [dict getdef $dictval {*}$path $default]
}
proc ::dictn::incr {dictvar path {increment {}} } {
if {$increment eq ""} {
::set increment 1
proc ::dictn::incr {dictvar path {increment 1} } {
upvar 1 $dictvar dvar
if {[llength $path] == 1} {
return [::tcl::dict::incr dvar $path $increment]
}
if {[::tcl::info::exists dvar]} {
::set increment [expr {[::tcl::dict::getdef $dvar {*}$path 0] + $increment}]
}
return [::tcl::dict::set dvar {*}$path $increment]
}
#test - compare disassembly
proc ::dictn::incr2 {dictvar path {increment 1} } {
if {[llength $path] == 1} {
uplevel 1 [list dict incr $dictvar $path $increment]
} else {
@ -233,6 +289,33 @@ proc ::dictn::set {dictvar path newval} {
return [dict set dvar {*}$path $newval]
}
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::setn
@cmd -name dictn::setn\
-summary\
"Set one or more paths in a dict to value(s)"\
-help\
""
@values -min 3 -max -1
dictvar -type string
path_newval -type {path newval} -multiple 1
}]
}
proc ::dictn::setn {dictvar args} {
if {[llength $args] == 0} {
error "dictn::setn requires at least one <path> <newval> pair"
}
if {[llength $args] % 2 != 0} {
error "dictn::setn requires trailing <path> <newval> pairs"
}
upvar 1 $dictvar dvar
foreach {p v} $args {
::tcl::dict::set dvar {*}$p $v
}
return $dvar
}
proc ::dictn::size {dictval {path {}}} {
return [dict size [dict get $dictval {*}$path]]
}
@ -312,6 +395,46 @@ proc ::dictn::values {dictval {path {}} {glob {}}} {
}
}
tcl::namespace::eval ::dictn::argdoc {
lappend PUNKARGS [list {
@id -id ::dictn::with
@cmd -name dictn::with\
-summary\
"Execute script for each key at dict path."\
-help\
"Execute the Tcl script in body with the value for each key within the
given key-path mapped to either variables or keys in a specified array.
If the name of an array variable is not supplied for arrayvar,
dictn with behaves like dict with, except that it accepts a list
for the possibly nested key-path instead of separate arguments.
The subkeys of the dict at the given key-path will create variables
in the calling scope.
If an arrayvar is passed, an array of that name in the calling
scope will be populated with keys and values from the subkeys and
values of the dict at the given key-path."
@form -form standard
@values -min 3 -max 3
dictvar -type string
path -type list
body -type string
@form -form array
@values -min 4 -max 4
dictvar -type string
path -type list
arrayvar -type string -help\
"Name of array variable in which key values are
stored for the given dict path.
This prevents key values being used as variable
names in the calling scope, instead capturing them
as keys in the single specified array at the calling
scope."
body -type string
}]
}
# Standard form:
#'dictn with dictVariable path body'
#
@ -351,7 +474,10 @@ proc ::dictn::with {dictvar path args} {
::tcl::namespace::eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::dictn
}

82
src/vfs/_vfscommon.vfs/modules/overtype-1.7.3.tm

@ -569,9 +569,10 @@ tcl::namespace::eval overtype {
#while {$overidx < [llength $inputchunks]} { }
while {[llength $inputchunks]} {
#set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx ""
set overtext [lpop inputchunks 0]
if {![tcl::string::length $overtext]} {
set overtext [lpop inputchunks 0] ;#could be a list 'ansisplit' or text 'plain|mixed'
#use eq test with emptystring instead of 'string length' - test for emptiness shouldn't cause shimmering if popped inputchunks member if an 'ansisplit' list
if {$overtext eq ""} {
incr loop
continue
}
@ -582,7 +583,6 @@ tcl::namespace::eval overtype {
#renderline pads each underaly line to width with spaces and should track where end of data is
#set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext]
set overtext $replay_codes_overlay$overtext
if {[tcl::dict::exists $replay_codes_underlay $row]} {
set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext
@ -827,6 +827,9 @@ tcl::namespace::eval overtype {
set foldline [tcl::dict::get $sub_info result]
tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
#todo!!!
# 2025 fix - this does nothing - so what uses it?? create a test!
linsert outputlines $renderedrow $foldline
#review - row & col set by restore - but not if there was no save..
}
@ -919,9 +922,23 @@ tcl::namespace::eval overtype {
set edit_mode 0
if {$edit_mode} {
set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied]
#set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied]
#JMN
ledit inputchunks -1 -1 $overflow_right$unapplied
set pt_ansi_pt [punk::ansi::ta::split_codes_single $overflow_right]
#join the trailing and leading pt parts of the 2 lists
ledit pt_ansi_pt end end "[lindex $pt_ansi_pt end][lindex $unapplied_list 0]"
lappend pt_ansi_pt [lrange $unapplied_list 1 end]
ledit inputchunks -1 -1 $pt_ansi_pt ;#combined overflow_right and unapplied - in ansisplit form
#JMN 2025
set overtext_type "ansisplit"
set overflow_right ""
set unapplied ""
set unapplied_list [list]
set row $post_render_row
#set col $post_render_col
set col $opt_startcolumn
@ -1311,7 +1328,9 @@ tcl::namespace::eval overtype {
}
if {$nextprefix ne ""} {
set inputchunks [linsert $inputchunks 0 $nextprefix]
#set inputchunks [linsert $inputchunks 0 $nextprefix]
#JMN - assume backwards compat ledit available from punk::lib (for tcl <9)
ledit inputchunks -1 -1 $nextprefix
}
@ -2026,7 +2045,10 @@ tcl::namespace::eval overtype {
-cursor_restore_attributes ""\
-cp437 0\
-experimental {}\
-overtext_type mixed\
]
#-overtext_type plain|mixed|ansisplit
#-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller
#cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return
@ -2040,7 +2062,7 @@ tcl::namespace::eval overtype {
switch -- $k {
-experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row
- -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode
- -info - -exposed1 - -exposed2 - -cursor_restore_attributes {
- -info - -exposed1 - -exposed2 - -cursor_restore_attributes - -overtext_type {
tcl::dict::set opts $k $v
}
default {
@ -2055,6 +2077,7 @@ tcl::namespace::eval overtype {
set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay
set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay
set opt_row_context [tcl::dict::get $opts -cursor_row]
set opt_overtext_type [tcl::dict::get $opts -overtext_type]
if {[string length $opt_row_context]} {
if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } {
error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'"
@ -2128,12 +2151,19 @@ tcl::namespace::eval overtype {
#set under [textutil::tabify::untabify2 $under]
set under [textutil::tabify::untabifyLine $under $tw]
}
#review - is untabifying sensible at this point??
if {$opt_overtext_type eq "ansisplit"} {
#todo - something for each pt part?
} else {
#plain|mixed
if {[string first \t $over] >= 0} {
#set overdata [textutil::tabify::untabify2 $over]
set overdata [textutil::tabify::untabifyLine $over $tw]
}
}
}
}
#-------
#ta_detect ansi and do simpler processing?
@ -2415,12 +2445,22 @@ tcl::namespace::eval overtype {
set startpadding [string repeat " " [expr {$opt_colstart -1}]]
#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency
if {$startpadding ne "" || $overdata ne ""} {
if {$opt_overtext_type eq "ansisplit"} {
set overmap $overdata
lset overmap 0 "$startpadding[lindex $overmap 0]"
} else {
if {[punk::ansi::ta::detect $overdata]} {
set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata]
#TODO!! rework this.
#e.g 200K+ input file with no newlines - we are wastefully calling split_codes_single repeatedly on mostly the same data.
#set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata]
set overmap [punk::ansi::ta::split_codes_single $overdata]
lset overmap 0 "$startpadding[lindex $overmap 0]"
} else {
#single plaintext part
set overmap [list $startpadding$overdata]
}
}
} else {
set overmap [list]
}
@ -2453,8 +2493,13 @@ tcl::namespace::eval overtype {
set pt_overchars ""
set i_o 0
set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use
#experiment
set overlay_grapheme_control_stacks [list]
#REVIEW - even if we pass in a pre-split overtext (-overtext_type ansisplit)
#we are re-generating the overlay_grapheme_control_stacks list each time
#this is a big issue when overtext is not broken into lines, but is just a big long ansi and/or plain text string.
#todo - return also the unapplied portion of the overlay_grapheme_control_stacks list??
foreach {pt code} $overmap {
if {$pt ne ""} {
#todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between)
@ -2725,7 +2770,9 @@ tcl::namespace::eval overtype {
if {[llength [split $chars ""]] > 1} {
priv::render_unapplied $overlay_grapheme_control_list $gci
#prefix the unapplied controls with the string version of this control
set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]]
#set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]]
#JMN - backwards compat ledit from punk::lib for tcl <9
ledit unapplied_list -1 -1 {*}[split $chars ""]
set unapplied [join $unapplied_list ""]
#incr idx_over
break
@ -3085,7 +3132,9 @@ tcl::namespace::eval overtype {
set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item]
priv::render_unapplied $overlay_grapheme_control_list $gci
#prefix the unapplied controls with the string version of this control
set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]]
#set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]]
#JMN
ledit unapplied_list -1 -1 {*}[split $chars ""]
set unapplied [join $unapplied_list ""]
break
@ -4923,13 +4972,18 @@ tcl::namespace::eval overtype::priv {
} else {
#insert of single-width vs double-width when underlying is double-width?
if {$i < $nxt} {
set o [linsert $o $i $c]
#set o [linsert $o $i $c]
#JMN insert via ledit
ledit o $i $i-1 $c
} else {
lappend o $c
}
if {$i < [llength $ustacks]} {
set ustacks [linsert $ustacks $i $sgrstack]
set gxstacks [linsert $gxstacks $i $gx0stack]
#set ustacks [linsert $ustacks $i $sgrstack]
#set gxstacks [linsert $gxstacks $i $gx0stack]
#insert via ledit
ledit ustacks $i $i-1 $sgrstack
ledit gxstacks $i $i-1 $gx0stack
} else {
lappend ustacks $sgrstack
lappend gxstacks $gx0stack

5199
src/vfs/_vfscommon.vfs/modules/overtype-1.7.4.tm

File diff suppressed because it is too large Load Diff

241
src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.5.tm

@ -751,6 +751,27 @@ namespace eval punk::lib {
# -- ---
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lswap
@cmd -name punk::lib::lswap\
-summary\
"Swap list values in-place"\
-help\
"Similar to struct::list swap, except it fully supports basic
list index expressions such as 7-2 end-1 etc.
struct::list swap doesn't support 'end' offsets, and only
sometimes appears to support basic expressions, depending on the
expression compared to the list length."
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
proc lswap {lvar a z} {
upvar $lvar l
set len [llength $l]
@ -955,42 +976,69 @@ namespace eval punk::lib {
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lzip
@cmd -name punk::lib::lzip\
-summary\
"zip any number of lists together."\
-help\
"Conceptually equivalent to converting a list of rows
to a list of columns.
The number of returned lists (columns) will be equal to
the length of the longest supplied list (row).
If lengths of supplied lists don't match, empty strings
will be inserted in the resulting lists.
e.g lzip {a b c d e} {1 2 3 4} {x y z}
-> {a 1 x} {b 2 y} {c 3 z} {d 4 {}} {3 {} {}}
"
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
proc lzip {args} {
switch -- [llength $args] {
0 {return {}}
1 {return [lindex $args 0]}
2 {return [lzip2lists {*}$args]}
3 {return [lzip3lists {*}$args]}
4 {return [lzip4lists {*}$args]}
5 {return [lzip5lists {*}$args]}
6 {return [lzip6lists {*}$args]}
7 {return [lzip7lists {*}$args]}
8 {return [lzip8lists {*}$args]}
9 {return [lzip9lists {*}$args]}
10 {return [lzip10lists {*}$args]}
2 {return [::punk::lib::system::lzip2lists {*}$args]}
3 {return [::punk::lib::system::lzip3lists {*}$args]}
4 {return [::punk::lib::system::lzip4lists {*}$args]}
5 {return [::punk::lib::system::lzip5lists {*}$args]}
6 {return [::punk::lib::system::lzip6lists {*}$args]}
7 {return [::punk::lib::system::lzip7lists {*}$args]}
8 {return [::punk::lib::system::lzip8lists {*}$args]}
9 {return [::punk::lib::system::lzip9lists {*}$args]}
10 {return [::punk::lib::system::lzip10lists {*}$args]}
11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 {
set n [llength $args]
if {[info commands ::punk::lib::lzip${n}lists] eq ""} {
puts "calling ::punk::lib::Build_lzipn $n"
::punk::lib::Build_lzipn $n
if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} {
#puts "calling ::punk::lib::system::Build_lzipn $n"
::punk::lib::system::Build_lzipn $n
}
return [lzip${n}lists {*}$args]
return [::punk::lib::system::lzip${n}lists {*}$args]
}
default {
if {[llength $args] < 4000} {
set n [llength $args]
if {[info commands ::punk::lib::lzip${n}lists] eq ""} {
puts "calling ::punk::lib::Build_lzipn $n"
::punk::lib::Build_lzipn $n
if {[info commands ::punk::lib::system::lzip${n}lists] eq ""} {
#puts "calling ::punk::lib::system::Build_lzipn $n"
::punk::lib::system::Build_lzipn $n
}
return [lzip${n}lists {*}$args]
return [::punk::lib::system::lzip${n}lists {*}$args]
} else {
return [lzipn {*}$args]
return [::punk::lib::lzipn {*}$args]
}
}
}
}
namespace eval system {
proc Build_lzipn {n} {
set arglist [list]
#use punk::lib::range which defers to lseq if available
@ -1005,10 +1053,10 @@ namespace eval punk::lib {
append body "\$[lindex $vars $i] "
}
append body "\}" \n
puts "proc punk::lib::lzip${n}lists {$arglist} \{"
puts "$body"
puts "\}"
proc ::punk::lib::lzip${n}lists $arglist $body
#puts "proc punk::lib::system::lzip${n}lists {$arglist} \{"
#puts "$body"
#puts "\}"
proc ::punk::lib::system::lzip${n}lists $arglist $body
}
#fastest is to know the number of lists to be zipped
@ -1053,6 +1101,7 @@ namespace eval punk::lib {
#2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?)
proc lzipn_tcl8 {args} {
#For tcl pre 9 (without lsearch -stride)
#wiki - courtesy JAL
set list_l $args
set zip_l []
@ -1068,6 +1117,7 @@ namespace eval punk::lib {
return $zip_l
}
proc lzipn_tcl9a {args} {
#For Tcl 9+ (with lsearch -stride)
#compared to wiki version
#comparable for lists len <3 or number of args < 3
#approx 2x faster for large lists or more lists
@ -1121,15 +1171,38 @@ namespace eval punk::lib {
}
return $zip_l
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lzipn
@cmd -name punk::lib::lzipn\
-summary\
"zip any number of lists together (unoptimised)."\
-help\
"Conceptually equivalent to converting a list of rows
to a list of columns.
See lzip which provides the same functionality but with
optimisations depending on the number of supplied lists.
"
@values -min 1 -max 1
lvar -type string -help\
"name of list variable"
a -type indexexpression
z -type indexexpression
}]
}
#keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible
if {![package vsatisfies [package present Tcl] 9.0-] || [dict get [punk::lib::check::has_tclbug_lsearch_strideallinline] bug]} {
#-stride either not available - or has bug preventing use of main algorithm below
proc lzipn {args} [info body ::punk::lib::lzipn_tcl8]
proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl8]
} else {
proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a]
proc lzipn {args} [info body ::punk::lib::system::lzipn_tcl9a]
}
namespace import ::punk::args::lib::tstr
namespace eval argdoc {
@ -2291,13 +2364,31 @@ namespace eval punk::lib {
proc is_list_all_ni_list2 {a b} $body
}
#somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist
#struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on,
# especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg)
proc ldiff {fromlist removeitems} {
if {[llength $removeitems] == 0} {return $fromlist}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::ldiff
@cmd -name punk::lib::ldiff\
-summary\
"Difference consisting of items with removeitems removed."\
-help\
"Somewhat like struct::set difference, but order preserving, and doesn't
treat as a 'set' so preserves any duplicates in items.
struct::set difference may happen to preserve ordering when items are
integers, but order can't be relied on, especially as struct::set has
2 differening implementations (tcl vs critcl) which return results with
different ordering to each other and different deduping behaviour in
some cases (e.g when 2nd arg is empty)"
@values -min 2 -max 2
items -type list
removeitems -type list
}]
}
proc ldiff {items removeitems} {
if {[llength $removeitems] == 0} {return $items}
set result {}
foreach item $fromlist {
foreach item $items {
if {$item ni $removeitems} {
lappend result $item
}
@ -2361,6 +2452,28 @@ namespace eval punk::lib {
return [array names tmp]
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lunique_unordered
@cmd -name punk::lib::lunique_unordered\
-summary\
"unique values in list"\
-help\
"Return unique values in provided list.
This removes duplicates but *may* rearrange the
order of the returned elements compared to the
original list.
When struct::set is available this will be used
for the implementation, as it can be *slightly*
faster if acceleration is present. When struct::set
is not available it will fallback to lunique and
provide the same functionality with order preserved."
@values -min 1 -max 1
list -type list
}]
}
#default/fallback implementation
proc lunique_unordered {list} {
lunique $list
@ -2371,13 +2484,33 @@ namespace eval punk::lib {
struct::set union $list {}
}
} else {
puts stderr "WARNING: struct::set union <list> <emptylist> no longer dedupes!"
#struct::set union operates on a 'set' - so this probably won't change, and hopefully is
#consistent across unacelerated versions and those implemented in accelerators,
#but if it ever does change - be a little noisy about it.
puts stderr "punk::lib WARNING: struct::set union <list> <emptylist> no longer dedupes!"
#we could also test a sequence of: struct::set add
}
}
#order-preserving
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lunique
@cmd -name punk::lib::lunique\
-summary\
"Order-preserving unique values in list"\
-help\
"Return unique values in provided list.
This removes duplicates whilst preserving the
original order of the provided list.
When struct::set is available with acceleration,
lunique_unordered may be slightly faster."
@values -min 1 -max 1
list -type list
}]
}
proc lunique {list} {
set new {}
foreach item $list {
@ -2569,7 +2702,7 @@ namespace eval punk::lib {
To validate if an indexset is strictly within range, both the length of the data and the base would
need to be considered.
The normal 'range' specifier is ..
The normal 'range' specifier is .. but can be of the form .x. where x is the step value.
The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire
range of valid values.
e.g the following are all valid ranges
@ -2581,6 +2714,9 @@ namespace eval punk::lib {
(index 2 to 11)
..
(all indices)
.3.
(1st index and every 3rd index thereafter)
Common whitespace elements space,tab,newlines are ignored.
Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands,
e.g end-2 or 2+2.
@ -2670,20 +2806,19 @@ namespace eval punk::lib {
.-1. would represent end to base with step -1
If start is omitted and only the end is supplied:
The default step is 1 indicating ascension and the missing end is equivalent to 'end'
indexset_resolve 5 2..
-> 2 3 4
The default end is the base if the step is negative
indexset_resolve 5 2.-1.
-> 2 1 0
If end is omitted and onlthe start is supplied:
The default step is 1 indicating ascension and the missing start is equivalent to the base.
indexset_resolve 5 ..2
-> 0 1 2
The default start is 'end' if the step is negative
indexset_resolve 5 .-1.2
-> 4 3 2
If end is omitted and only the start is supplied:
The default step is 1 indicating ascension and the missing end is equivalent to 'end'
indexset_resolve 5 2..
-> 2 3 4
The default end is the base if the step is negative
indexset_resolve 5 2.-1.
-> 2 1 0
Like the tcl9 lseq command - a step (by) value of zero produces no results.
@ -2703,7 +2838,7 @@ namespace eval punk::lib {
indexset examples:
These assume the default 0-based indices (base == 0)
These assume the default 0-based indices (-base 0)
1,3..
output the index 1 (2nd item) followed by all from index 3 to the end.
@ -3604,7 +3739,7 @@ namespace eval punk::lib {
@id -id ::punk::lib::gcd
@cmd -name punk::lib::gcd\
-summary\
"Gretest common divisor of m and n."\
"Greatest common divisor of m and n."\
-help\
"Return the greatest common divisor of m and n.
Straight from Lars Hellström's math::numtheory library in Tcllib
@ -3643,12 +3778,22 @@ namespace eval punk::lib {
return $m
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::lcm
@cmd -name punk::lib::lcm\
-summary\
"Lowest common multiple of m and n."\
-help\
"Return the lowest common multiple of m and n.
Straight from Lars Hellström's math::numtheory library in Tcllib"
@values -min 2 -max 2
m -type integer
n -type integer
}]
}
proc lcm {n m} {
#*** !doctools
#[call [fun gcd] [arg n] [arg m]]
#[para]Return the lowest common multiple of m and n
#[para]Straight from Lars Hellström's math::numtheory library in Tcllib
#[para]
set gcd [gcd $n $m]
return [expr {$n*$m/$gcd}]
}

3
src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm

@ -1036,7 +1036,8 @@ namespace eval punk::repl::class {
# set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
# incr nextrow -1
#}
set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
#set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""]
ledit o_rendered_lines $cursor_row_idx $cursor_row_idx-1 ""
set o_cursor_col 1
}

18
src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm

@ -323,7 +323,8 @@ namespace eval punkcheck {
if {$isnew} {
lappend record_list $o_fileset_record
} else {
set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record]
#set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record]
ledit record_list $oldposition $oldposition-1 $o_fileset_record
}
if {$o_operation ne "QUERY"} {
punkcheck::save_records_to_file $record_list $punkcheck_file
@ -536,7 +537,8 @@ namespace eval punkcheck {
set existing_header_posn [dict get $resultinfo position]
if {$existing_header_posn == -1} {
set this_installer_record [punkcheck::recordlist::new_installer_record $o_name]
set o_record_list [linsert $o_record_list 0 $this_installer_record]
#set o_record_list [linsert $o_record_list 0 $this_installer_record]
ledit o_record_list -1 -1 $this_installer_record
} else {
set this_installer_record [dict get $resultinfo record]
}
@ -616,7 +618,8 @@ namespace eval punkcheck {
set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records]
set existing_header_posn [dict get $persistedinfo position]
if {$existing_header_posn == -1} {
set file_records [linsert $file_records 0 $this_installer_record]
#set file_records [linsert $file_records 0 $this_installer_record]
ledit file_records -1 -1 $this_installer_record
} else {
lset file_records $existing_header_posn $this_installer_record
}
@ -710,7 +713,8 @@ namespace eval punkcheck {
if {$existing_header_posn == -1} {
#not found - prepend
set record_list [linsert $record_list 0 $this_installer_record]
#set record_list [linsert $record_list 0 $this_installer_record]
ledit record_list -1 -1 $this_installer_record
} else {
#replace
lset record_list $existing_header_posn $this_installer_record
@ -791,7 +795,8 @@ namespace eval punkcheck {
if {$isnew} {
lappend record_list $file_record
} else {
set record_list [linsert $record_list[unset record_list] $oldposition $file_record]
#set record_list [linsert $record_list[unset record_list] $oldposition $file_record]
ledit record_list $oldposition $oldposition-1 $file_record
}
save_records_to_file $record_list $punkcheck_file
@ -1191,7 +1196,8 @@ namespace eval punkcheck {
# dst is: base/sub = sub
while {$baselen > 0} {
set dst [linsert $dst 0 ..]
#set dst [linsert $dst 0 ..]
ledit dst -1 -1 ..
incr baselen -1
}
set dst [file join {*}$dst]

32
src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm

@ -4480,7 +4480,8 @@ tcl::namespace::eval textblock {
set code_idx 3
foreach {pt code} [lrange $parts 2 end] {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts $code_idx+1 $base]
#set parts [linsert $parts $code_idx+1 $base]
ledit parts $code_idx+1 $code_idx $base
}
incr code_idx 2
}
@ -4504,12 +4505,14 @@ tcl::namespace::eval textblock {
#first pt & code
if {$pt ne ""} {
#leading plaintext
set parts [linsert $parts 0 $base]
#set parts [linsert $parts 0 $base]
ledit parts -1 -1 $base
incr offset
}
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts [expr {$code_idx+1+$offset}] $base]
#ledit parts [expr {$code_idx+1+$offset}] $code_idx+$offset $base
incr offset
}
incr code_idx 2
@ -5371,6 +5374,9 @@ tcl::namespace::eval textblock {
r-1 {
if {[lindex $line_chunks end] eq ""} {
set line_chunks [linsert $line_chunks end-2 $pad]
#breaks layout e.g subtables in: i i
#why?
#ledit line_chunks end-2 end-3 $pad
} else {
lappend line_chunks $pad
}
@ -5379,13 +5385,16 @@ tcl::namespace::eval textblock {
lappend line_chunks $pad
}
l-0 {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
l-1 {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
#set line_chunks [linsert $line_chunks 2 $pad]
ledit line_chunks 2 1 $pad
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
l-2 {
@ -5393,10 +5402,12 @@ tcl::namespace::eval textblock {
if {[lindex $line_chunks 0] eq ""} {
set line_chunks [linsert $line_chunks 2 $pad]
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
} else {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
}
@ -5466,14 +5477,17 @@ tcl::namespace::eval textblock {
#} else {
# set line_chunks [linsert $line_chunks 0 $pad]
#}
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
l-1 {
#set line_chunks [linsert $line_chunks 0 $pad]
set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks]
}
l-2 {
set line_chunks [linsert $line_chunks 0 $pad]
#set line_chunks [linsert $line_chunks 0 $pad]
ledit line_chunks -1 -1 $pad
}
}
}

Loading…
Cancel
Save