Browse Source

textblock unicode and table work, function documentation (i command)

master
Julian Noble 3 months ago
parent
commit
ca1d9f422f
  1. 44
      src/bootsupport/modules/overtype-1.6.5.tm
  2. 164
      src/bootsupport/modules/punk-0.1.tm
  3. 19
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  4. 87
      src/bootsupport/modules/punk/args-0.1.0.tm
  5. 248
      src/bootsupport/modules/punk/char-0.1.0.tm
  6. 1
      src/bootsupport/modules/punk/console-0.1.1.tm
  7. 56
      src/bootsupport/modules/punk/lib-0.1.1.tm
  8. 22
      src/bootsupport/modules/punk/ns-0.1.0.tm
  9. 2
      src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
  10. 225
      src/bootsupport/modules/textblock-0.1.2.tm
  11. 42
      src/doc/_module_termscheme-0.1.0.tm.man
  12. 2
      src/doc/punk/_module_ansi-0.1.1.tm.man
  13. 20
      src/doc/punk/_module_args-0.1.0.tm.man
  14. 2
      src/doc/punk/_module_console-0.1.1.tm.man
  15. 1
      src/doc/punk/_module_lib-0.1.1.tm.man
  16. 43
      src/doc/punk/_module_safe-0.1.0.tm.man
  17. 42
      src/doc/punk/_module_sixel-0.1.0.tm.man
  18. 43
      src/doc/punk/args/_module_tclcore-0.1.0.tm.man
  19. 2
      src/doc/punk/nav/_module_fs-0.1.0.tm.man
  20. 6
      src/doc/punk/repl/_module_codethread-0.1.0.tm.man
  21. 37
      src/doc/punk/repl/_module_codethread-0.1.1.tm.man
  22. 164
      src/modules/punk-0.1.tm
  23. 19
      src/modules/punk/ansi-999999.0a1.0.tm
  24. 87
      src/modules/punk/args-999999.0a1.0.tm
  25. 65
      src/modules/punk/args/tclcore-999999.0a1.0.tm
  26. 248
      src/modules/punk/char-999999.0a1.0.tm
  27. 1
      src/modules/punk/console-999999.0a1.0.tm
  28. 56
      src/modules/punk/lib-999999.0a1.0.tm
  29. 5
      src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm
  30. 22
      src/modules/punk/ns-999999.0a1.0.tm
  31. 17
      src/modules/punk/repl-0.1.tm
  32. 2
      src/modules/punk/repl/codethread-999999.0a1.0.tm
  33. 225
      src/modules/textblock-999999.0a1.0.tm
  34. 44
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm
  35. 164
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm
  36. 19
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  37. 87
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
  38. 248
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm
  39. 1
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
  40. 56
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm
  41. 22
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  42. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
  43. 225
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm
  44. 44
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm
  45. 164
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm
  46. 19
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  47. 87
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
  48. 248
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm
  49. 1
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
  50. 56
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm
  51. 22
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  52. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
  53. 225
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm
  54. 42
      src/vendormodules/overtype-1.6.5.tm
  55. 42
      src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm
  56. 164
      src/vfs/_vfscommon.vfs/modules/punk-0.1.tm
  57. 19
      src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm
  58. 87
      src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm
  59. 65
      src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm
  60. 248
      src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm
  61. 1
      src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm
  62. 56
      src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm
  63. 22
      src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm
  64. 17
      src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm
  65. 2
      src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm
  66. 225
      src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm

44
src/bootsupport/modules/overtype-1.6.5.tm

@ -729,7 +729,7 @@ tcl::namespace::eval overtype {
-width [tcl::dict::get $vtstate renderwidth]\
-insert_mode [tcl::dict::get $vtstate insert_mode]\
-autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\
-expand_right [tcl::dict::get $opts -opt_expand_right]\
-expand_right [tcl::dict::get $opts -expand_right]\
""\
$overflow_right\
]
@ -1366,7 +1366,7 @@ tcl::namespace::eval overtype {
if {$overflowlength > 0} {
#overlay line wider or equal
#review - we still expand_right for centred for now.. possibly should expand_both with ellipsis each end?
#review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end?
set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
@ -1771,7 +1771,7 @@ tcl::namespace::eval overtype {
#-returnextra enables returning of overflow and length
#review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation?
#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements
#(could render it by faking it with sixels and a lot of work - find/make a sixel font (converter?) and ensure it's exactly 2 cols per char?
#(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char?
# This would probably be impractical to support for different fonts)
#todo - review transparency issues with single/double width characters
#bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer?
@ -2815,6 +2815,7 @@ tcl::namespace::eval overtype {
\x1b\[< 1006\
\x1b\[ 7CSI\
\x1bP 7DCS\
\x90 8DCS\
\x9b 8CSI\
\x1b\] 7OSC\
\x9d 8OSC\
@ -2836,6 +2837,10 @@ tcl::namespace::eval overtype {
#Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]]
}
8DCS {
#8-bit Device Control String
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
7ESC {
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
@ -3265,6 +3270,17 @@ tcl::namespace::eval overtype {
puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
T {
#CSI Pn T - SD Pan Up (empty lines introduced at top)
#CSI Pn+T - kitty extension (lines at top come from scrollback buffer)
#Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display
if {$param eq "" || $param eq "0"} {set param 1}
if {[string index $param end] eq "+"} {
puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
} else {
puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
X {
puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param"
#ECH - erase character
@ -3862,9 +3878,14 @@ tcl::namespace::eval overtype {
}
}
7DCS {
7DCS - 8DCS {
puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
#
#ST (string terminator) \x9c or \x1b\\
if {[tcl::string::index $codenorm end] eq "\x9c"} {
set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c
} else {
set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\
}
}
7OSC - 8OSC {
@ -3934,6 +3955,12 @@ tcl::namespace::eval overtype {
#tektronix cursor color
puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
99 {
#kitty desktop notifications
#https://sw.kovidgoyal.net/kitty/desktop-notifications/
#<OSC> 99 ; metadata ; payload <terminator>
puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
104 {
#reset colour palette
#we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt
@ -3942,6 +3969,13 @@ tcl::namespace::eval overtype {
set instruction [list reset_colour_palette]
break
}
1337 {
#iterm2 graphics and file transfer
puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]"
}
5113 {
puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]"
}
default {
puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}

164
src/bootsupport/modules/punk-0.1.tm

@ -101,12 +101,15 @@ set punk_testd2 [dict create \
] \
]
#impolitely cooperative withe punk repl - todo - tone it down.
#impolitely cooperative with punk repl - todo - tone it down.
#namespace eval ::punk::repl::codethread {
# variable running 0
#}
package require punk::lib
package require punk::lib ;# subdependency punk::args
package require punk::ansi
if {![llength [info commands ::ansistring]]} {
namespace import punk::ansi::ansistring
}
#require aliascore after punk::lib & punk::ansi are loaded
package require punk::aliascore ;#mostly punk::lib aliases
punk::aliascore::init
@ -114,9 +117,6 @@ punk::aliascore::init
package require punk::repl::codethread
package require punk::config
#package require textblock
if {![llength [info commands ::ansistring]]} {
namespace import punk::ansi::ansistring
}
package require punk::console
package require punk::ns
package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems
@ -862,6 +862,8 @@ namespace eval punk {
}
}
#? {
#review - compare to %# ?????
#seems to be unimplemented ?
set assigned [string length $leveldata]
set already_assigned 1
}
@ -7149,12 +7151,93 @@ namespace eval punk {
dict filter $result value {?*}
}
punk::args::definition {
*id punk::inspect
*proc -name punk::inspect -help\
"Function to display values - used pimarily in a punk pipeline.
The raw value arguments (not options) are always returned to pass
forward in the pipeline.
(pipeline data inserted at end of each |...> segment is passed as single item unless
inserted with an expanding insertion specifier such as .=>* )
e.g1:
.= list a b c |v1,/1-end,/0>\\
.=>* inspect -label i1 -- |>\\
.=v1> inspect -label i2 -- |>\\
string toupper
(3) i1: {a b c} {b c} a
(1) i2: a b c
- A B C
"
-label -type string -default "" -help\
"An optional label to help distinguish output when multiple
inspect statements are in a pipeline. This appears after the
bracketed count indicating number of values supplied.
e.g (2) MYLABEL: val1 val2
The label can include ANSI codes.
e.g
inspect -label [a+ red]mylabel -- val1 val2 val3
"
-limit -type int -default 20 -help\
"When multiple values are passed to inspect - limit the number
of elements displayed in -channel output.
When truncation has occured an elipsis indication (...) will be appended.
e.g
.= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+
(11) 20 23 26 29...
- 385
For no limit - use -limit -1
"
-channel -type string -default stderr -help\
"An existing open channel to write to. If value is any of nul, null, /dev/nul
the channel output is disabled. This effectively disables inspect as the args
are simply passed through in the return to continue the pipeline.
"
-showcount -type boolean -default 1 -help\
"Display a leading indicator in brackets showing the number of arg values present."
-ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels {
0 "Strip ANSI codes from display
of values. The disply output will
still be colourised if -ansibase has
not been set to empty string or
[a+ normal]. The stderr or stdout
channels may also have an ansi colour.
(see 'colour off' or punk::config)"
1 "Leave value as is"
2 "Display the ANSI codes and
other control characters inline
with replacement indicators.
e.g esc, newline, space, tab"
VIEW "Alias for 2"
3 "Display as per 2 but with
colourised ANSI replacement codes."
VIEWCODES "Alias for 3"
4 "Display ANSI and control
chars in default colour, but
apply the contained ansi to
the text portions so they display
as they would for -ansi 1"
VIEWSTYLE "Alias for 4"
}
-ansibase -type ansistring -default {${[a+ brightgreen]}} -help\
"Base ansi code(s) that will apply to output written to the chosen -channel.
If there are ansi resets in the displayed values - output will revert to this base.
Does not affect return value."
-- -type none -help\
"End of options marker.
It is advisable to use this, as data in a pipeline may often being with -"
*values -min 0 -max -1
arg -type string -optional 1 -multiple 1 -help\
"value to display"
}
#pipeline inspect
#e.g
#= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data}
proc inspect {args} {
set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1]
set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1 -ansibase [a+ brightgreen]]
set flags [list]
set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect --
if {$endoptsposn >= 0} {
@ -7177,24 +7260,28 @@ namespace eval punk {
}
foreach {k v} $flags {
if {$k ni [dict keys $defaults]} {
error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --"
#error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --"
punk::args::get_by_id punk::inspect $args
}
}
set opts [dict merge $defaults $flags]
# -- --- --- --- ---
set label [dict get $opts -label]
set channel [dict get $opts -channel]
set showcount [dict get $opts -showcount]
set label [dict get $opts -label]
set channel [dict get $opts -channel]
set showcount [dict get $opts -showcount]
if {[string length $label]} {
set label "${label}: "
}
set limit [dict get $opts -limit]
set opt_ansi [dict get $opts -ansi]
set opt_ansiraw [dict get $opts -ansi]
set opt_ansi [tcl::prefix::match -error "" [list 0 1 2 3 4 view viewcodes viewstyle] [string tolower $opt_ansiraw]]
switch -- [string tolower $opt_ansi] {
0 - 1 - 2 {}
view {set opt_ansi 2}
0 - 1 - 2 - 3 - 4 {}
view {set opt_ansi 2}
viewcodes {set opt_ansi 3}
viewstyle {set opt_ansi 4}
default {
error "inspect -ansi 0|1|2|view - received -ansi $opt_ansi"
error "inspect -ansi 0|1|2|view|3|viewcodes|4|viewstyle - received -ansi $opt_ansiraw"
}
}
# -- --- --- --- ---
@ -7248,15 +7335,50 @@ namespace eval punk {
} else {
set displaycount ""
}
if {$opt_ansi == 0} {
set displayval [punk::ansi::ansistrip $displayval]
} elseif {$opt_ansi == 2} {
set displayval [ansistring VIEW $displayval]
set ansibase [dict get $opts -ansibase]
if {$ansibase ne ""} {
#-ansibase default is hardcoded into punk::args definition
#run a test using any ansi code to see if colour is still enabled
if {[a+ red] eq ""} {
set ansibase "" ;#colour seems to be disabled
}
}
switch -- $opt_ansi {
0 {
set displayval $ansibase[punk::ansi::ansistrip $displayval]
}
1 {
#val may have ansi - including resets. Pass through ansibase_lines to
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
2 {
set displayval $ansibase[ansistring VIEW $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
3 {
set displayval $ansibase[ansistring VIEWCODE $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
4 {
set displayval $ansibase[ansistring VIEWSTYLE $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
}
if {![string length $more]} {
puts $channel "$displaycount$label[a green bold]$displayval[a]"
puts $channel "$displaycount$label$displayval[a]"
} else {
puts $channel "$displaycount$label[a green bold]$displayval[a yellow bold]$more[a]"
puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]"
}
return $val
}

19
src/bootsupport/modules/punk/ansi-0.1.1.tm

@ -167,6 +167,7 @@ tcl::namespace::eval punk::ansi::class {
}
default {
puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x"
punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args
}
}
}
@ -2415,6 +2416,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
*id punk::ansi::a+
*proc -name "punk::ansi::a+" -help\
"Returns an ANSI sgr escape sequence based on the list of supplied codes.
Unlike punk::ansi::a - it is not prefixed with an ANSI reset.
"
*values -min 0 -max -1
} [string map [list <choices> [dict keys $SGR_map]] {
@ -2432,10 +2434,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
The acceptable values for <termcolour> and <webcolour> can be queried using
punk::ansi::a? term
and
punk::ansi::a? web"
punk::ansi::a? web
Example to set foreground red and background cyan followed by a reset:
set str \"[a+ red Cyan]sample text[a]\"
"
}]]
proc a+ {args} {
#*** !doctools
#[call [fun a+] [opt {ansicode...}]]
@ -7065,13 +7069,12 @@ tcl::namespace::eval punk::ansi::ansistring {
}
}
#inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi
#todo - document
interp alias {} ansistring {} ::punk::ansi::ansistring
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}]
}
tcl::namespace::eval punk::ansi::control {
proc APC {args} {
return \x1b_[join $args {;}]\x1b\\
@ -7393,6 +7396,10 @@ tcl::namespace::eval punk::ansi::internal {
}
}
#inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi
#todo - document
interp alias {} ansistring {} ::punk::ansi::ansistring
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set NAMESPACES [list]

87
src/bootsupport/modules/punk/args-0.1.0.tm

@ -353,7 +353,7 @@ tcl::namespace::eval punk::args {
}
set optionspecs [join $normargs \n]
if {[string first \$\{ $optionspecs] > 0} {
set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 $optionspecs]]
set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]]
}
} else {
if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} {
@ -1262,30 +1262,43 @@ tcl::namespace::eval punk::args {
if {$arg_error_isrunning} {
error "arg_error already running - error in arg_error?\n triggering errmsg: $msg"
}
set arg_error_isrunning 1
if {[llength $args] %2 != 0} {
error "error in arg_error processing - expected opt/val pairs after msg and spec_dict"
}
set arg_error_isrunning 1
set badarg ""
set returntype error
set returntype table ;#table as string
set as_error 1 ;#usual case is to raise an error
dict for {k v} $args {
switch -- $k {
-badarg {
set badarg $v
}
-aserror {
if {![string is boolean -strict $v]} {
set arg_error_isrunning 0
error "arg_error invalid value for option -aserror. Received '$v' expected a boolean"
}
set as_error $v
}
-return {
if {$v ni {error string}} {
error "arg_error invalid value for option -return. Received '$v' expected one of: error string"
if {$v ni {string table tableobject}} {
set arg_error_isrunning 0
error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject"
}
set returntype $v
}
default {
set arg_error_isrunning 0
error "arg_error invalid option $k. Known_options: -badarg -return"
}
}
}
set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist.
#REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error
#e.g list_as_table
@ -1300,12 +1313,20 @@ tcl::namespace::eval punk::args {
#couldn't load textblock package
#just return the original errmsg without formatting
}
set use_table 0
if {$has_textblock && $returntype in {table tableobject}} {
set use_table 1
}
set errlines [list] ;#for non-textblock output
if {[catch {
if {$has_textblock} {
if {$use_table} {
append errmsg \n
} else {
append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n
if {($returntype in {table tableobject}) && !$has_textblock} {
append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n
} else {
append errmsg \n
}
}
set procname [Dict_getdef $spec_dict proc_info -name ""]
set prochelp [Dict_getdef $spec_dict proc_info -help ""]
@ -1333,7 +1354,7 @@ tcl::namespace::eval punk::args {
} else {
set docurl_display ""
}
if {$has_textblock} {
if {$use_table} {
set t [textblock::class::table new [a+ brightyellow]Usage[a]]
$t add_column -headers $blank_header_col -minwidth 3
$t add_column -headers $blank_header_col
@ -1343,7 +1364,7 @@ tcl::namespace::eval punk::args {
}
set h 0
if {$procname ne ""} {
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display]
} else {
lappend errlines "PROC/METHOD: $procname_display"
@ -1351,7 +1372,7 @@ tcl::namespace::eval punk::args {
incr h
}
if {$prochelp ne ""} {
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list Description: $prochelp_display]
} else {
lappend errlines "Description: $prochelp_display"
@ -1362,14 +1383,14 @@ tcl::namespace::eval punk::args {
if {![catch {package require punk::ansi}]} {
set docurl [punk::ansi::hyperlink $docurl]
}
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list $docname $docurl_display]
} else {
lappend errlines "$docname $docurl_display"
}
incr h
}
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -values {Arg Type Default Multi Help}
} else {
lappend errlines " --ARGUMENTS-- "
@ -1519,7 +1540,7 @@ tcl::namespace::eval punk::args {
set numcols [llength $formattedchoices]
}
if {$numcols > 0} {
if {$has_textblock} {
if {$use_table} {
#risk of recursing
set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices]
append help \n[textblock::join -- " " $choicetable]
@ -1565,7 +1586,7 @@ tcl::namespace::eval punk::args {
append typeshow \n "-range [dict get $arginfo -range]"
}
if {$has_textblock} {
if {$use_table} {
$t add_row [list $argshow $typeshow $default $multiple $help]
if {$arg eq $badarg} {
$t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG
@ -1577,11 +1598,14 @@ tcl::namespace::eval punk::args {
}
}
if {$has_textblock} {
if {$use_table} {
$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow]
$t configure -maxwidth 80
$t configure -maxwidth 80 ;#review
append errmsg [$t print]
$t destroy
if {$returntype ne "tableobject"} {
#returntype of table means just the text of the table
$t destroy
}
} else {
append errmsg [join $errlines \n]
}
@ -1595,11 +1619,22 @@ tcl::namespace::eval punk::args {
}
set arg_error_isrunning 0
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
if {$returntype eq "error"} {
return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg
#Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
if {$use_table} {
#assert returntype is one of table, tableobject
set result $errmsg ;#default if for some reason table couldn't be used
if {$returntype eq "tableobject"} {
if {[info object isa object $t]} {
set result $t
}
}
} else {
return $errmsg
set result $errmsg
}
if {$as_error} {
return -code error -errorcode {TCL WRONGARGS PUNK} $result
} else {
return $result
}
}
@ -1609,17 +1644,21 @@ tcl::namespace::eval punk::args {
*proc -name punk::args::usage -help\
"return usage information as a string
in table form."
-return -default table -choices {string table tableobject}
*values -min 0 -max 1
id -help\
"exact id.
Will usually match the command name"
}]
proc usage {id} {
proc usage {args} {
lassign [dict values [punk::args::get_by_id punk::args::usage $args]] leaders opts values received
set id [dict get $values id]
set speclist [get_spec $id]
if {[llength $speclist] == 0} {
error "punk::args::usage - no such id: $id"
}
arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] -return string
arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] {*}$opts -aserror 0
}
lappend PUNKARGS [list {
@ -2726,7 +2765,7 @@ tcl::namespace::eval punk::args::lib {
*id punk::args::lib::tstr
*proc -name punk::args::lib::tstr -help\
"A rough equivalent of js template literals"
-allowcommands -default -1 -type none -help\
-allowcommands -default 0 -type none -help\
"if -allowcommands is present, placeholder can contain commands e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}"
-return -default list -choices {dict list string args}\
-choicelabels {

248
src/bootsupport/modules/punk/char-0.1.0.tm

@ -600,6 +600,48 @@ tcl::namespace::eval punk::char {
puts stdout \n
puts stdout "cursor position immediately after outputing 3 bytes (xyz): $cursorposn"
}
proc test_zalgo {} {
#from: https://github.com/jameslanska/unicode-display-width/blob/5e28d94c75e8c421a87199363b85c90dc37125b8/docs/unicode_background.md
#see: https://lingojam.com/ZalgoText
puts stdout "44 chars long - 9 graphemes - 9 columns wide"
set str "Ẓ̌á̲l͔̝̞̄̑͌g̖̘̘̔̔͢͞͝o̪̔T̢̙̫̈̍͞e̬͈͕͌̏͑x̺̍̓̓ͅ"
}
proc test_zalgo2 {} {
# ------------------------
set str "Z̸̢͉̣͔̭̪͙̖̳̘͈͍̤̩̟͈͈͕̯̅̏̆̓̌́́͌̿̕ͅą̷̦̤̫̩͕̥̐̎̓́́̂̀͆́̔̄̈́̏̌́̆͜͜͝͠l̴̩̙̺͚̟͇͖͔͕̹̟͌̈́̄̇́̉̋̕̚͜͠͠g̸͇̩͔̺̝̗̥̖̙̑̈́̈́̿̾̌͌͊̈̀͊̑̇̑͌̍̅̌͊͜͠͝ǫ̴̢̧͎͔̞̤̻̱̮̬͕̗̭͍̣̠̳̆̀̋̓͒̾̄͜͝͠͝T̴̛͉̬̋́̈́̈́̓͗̍̏̔̈̋̀͐̓̎̅̚̕͠͝͝ê̵̖̖̈͊̔̓̔̐̓̃͊̋͋̎͂͋̕x̴̡͎͖̼͎̦͎̲̪̘̺̯̲̬̮̥̼̰͌̃͜ͅt̶̛̘͎̰̔͐͌́̈́͊͗͌̅͂̐̆͌̀͂͘"
# ------------------------
}
proc test_zalgo3 {} {
# ------------------------
set str "Ẕ̸̢̼̺̜̰̣̣̖̭̜͓͖̺̥̼̠͙͙̟̥̟̠̤̫͍̠̤̮͚̝̜̙͈̦̙̩̹̙̜̩̦͔͕̈̃̅̇̈́͂̇̽̈́́́́̎͊̂̑̋͆̔̾͋̚͜ͅã̵̛̪̽̎̃͑̒̇͋͂̽̃̍͊̀̈̊̊̔̊̆̈́͗͑͗̽̄̋͗̄͌̑͊͝͝͠ͅl̵̢͇̖͉͖̝̹̜̞͓͎͍͈̞̱̙͙̦̪͔̱̮͈͉̼͎̭̝̯͇͚̺̟̱͙̳̰̙͚͖̝̫͙̎̅̃͆̈́̋̌̔̋̋͗̈́̔̐͆̈́̓̾̄̀́̏́͒̆̌͒̈́̈́̾̏̀͜͝g̸̖͂͋̊͗̈́̓̆̈̋̒͐̕o̶̧̢͓̲̗̠̘͕̦̤̹̗͉̰͔̯͓̭̹̻͔͇̯̜̙̍̂̃̃̀̓͌̒͊̊̋̒̿̿̌͐̄͗̾̕͝T̶̛̳̜̰͍̹̻̫̠̱̼̼̙̆̑̾̾͛́́̿͋͌̎̀̀̽̆͌̽̂̈̇̅̇̃́̿͗̾͒̎͊̑̾͝͠ȩ̸̢̨̛̛̛̭͔͎͇̫͎͈̲̻̙͕͎̣͈̩̺̗͖͙͇͌͐̒̎͐̓́̉́͐̓̐͌̅̊͋͑̈́͗͑̏̕͜͜͝ͅx̸̧̧̛̖̣̥̘͎͎̳̭̙̦̝͖̝̮̱̹̯̺̙̩̯̮͖̻̰͓̰̩͇̥̑͌̊̐̉̏͆̓̑̎̊̓͒̂̄̆͆̀̊̄̈̽͐͛̏͊̓̌͑́̎̈́̍̈́̊͗̉̋͆̿̊͘͜͜͝͝ͅͅͅt̵̡̨̜̘͎̦͚̠̗̺͉̼̠̲̠͙̺̹̗̲̏̈́̂̚͜͜͝ͅ"
# ------------------------
}
proc test_farmer {} {
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
@ -620,17 +662,29 @@ tcl::namespace::eval punk::char {
puts stdout "farmer2 with no joiner codes: \\U0001f9d1\\U001f33e : $farmer2"
package require punk::console
puts stdout \n
puts stdout "#2--5---9---C---"
puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1
puts -nonewline "${farmer1}";set cursorposn [punk::console::get_cursor_pos]
puts stdout \n
puts stdout "cursor position immediately after outputing farmer1 (expecting 1 glyph 2 wide) : $cursorposn"
puts -nonewline "${farmer1}";set cursorposn [punk::console::get_cursor_pos_list]
puts stdout "\ncursor position immediately after outputing farmer1 (expecting 1 glyph 2 wide) : cursor at col [lindex $cursorposn 1]"
if {[lindex $cursorposn 1] eq "3"} {
puts stdout "[a+ green]OK[a]"
} else {
puts stdout "[a+ red]ERR - expected cursor position to be 3 after emitting farmer1[a]"
}
puts stdout "----------------"
puts stdout "#2--5---9---C---"
puts -nonewline "${farmer2}";set cursorposn [punk::console::get_cursor_pos]
puts stdout \n
puts stdout "cursor position immediately after outputing farmer2 (expecting 2 glyphs 4 wide in total): $cursorposn"
puts -nonewline "${farmer2}";set cursorposn [punk::console::get_cursor_pos_list]
puts stdout "\ncursor position immediately after outputing farmer2 (expecting 2 glyphs 4 wide in total): cursor at col [lindex $cursorposn 1]"
if {[lindex $cursorposn 1] eq "5"} {
puts stdout "[a+ green]OK[a]"
} else {
puts stdout "[a+ red]ERR - expected cursor position to be 5 after emitting farmer2[a]"
}
puts stdout "----------------"
return [list $farmer1 $farmer2]
puts "returning farmer1 - should be single glyph"
return $farmer1
}
#G0 Sets Sequence G1 Sets Sequence Meaning
@ -1916,6 +1970,172 @@ tcl::namespace::eval punk::char {
# - tab/vtab?
# - compare with wcswidth returning -1 for entire string containing such in python,perl
proc wcswidth {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?)
#Tcl initial evaluation stack size is 2000 (? review)
#REVIEW - when we cater for grapheme clusters - we can't just split the string at arbitrary points like this!!
set chunksize 2000
set chunks_required [expr {int(ceil([tcl::string::length $string] / double($chunksize)))}]
set width 0
set startidx 0
set endidx [expr {$startidx + $chunksize -1}]
for {set i 0} {$i < $chunks_required} {incr i} {
set chunk [tcl::string::range $string $startidx $endidx]
set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]]
foreach c $codes {
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
incr startidx $chunksize
incr endidx $chunksize
}
return $width
}
# ------------------------------------------------------------------------------------------------------
#test
# ------------------------------------------------------------------------------------------------------
proc grapheme_split_tk {string} {
if {![regexp "\[\uFF-\U10FFFF\]" $string]} {
#only ascii - no joiners or unicode
return [split $string {}]
}
package require tk
set i 0
set graphemes [list]
while {$i < [tcl::string::length $string]} {
set aftercluster [tk::endOfCluster $string $i]
lappend graphemes [string range $string $i $aftercluster-1]
set i $aftercluster
}
return $graphemes
}
proc wcswidth_clustered {string} {
package require tk
set width 0
set i 0
if {![regexp "\[\uFF-\U10FFFF\]" $string]} {
return [punk::char::wcswidth_unclustered $string] ;#still use our wcswidth to account for non-printable ascii
}
while {$i < [tcl::string::length $string]} {
set aftercluster [tk::endOfCluster $string $i]
set g [string range $string $i $aftercluster-1]
if {$aftercluster > ($i + 1)} {
#review - proper way to determine screen width (columns occupied) of a cluster??
#according to this:
#https://lib.rs/crates/unicode-display-width
#for each grapheme - if any of the code points in the cluster have an east asian width of 2,
#The entire grapheme width is 2 regardless of how many code points constitute the grapheme
set gw 1
foreach ch [split $g ""] {
if {[punk::char::wcswidth_single $ch] == 2} {
set gw 2
break
}
}
incr width $gw
#if {[string first \u200d $g] >=0} {
# incr width 2
#} else {
# #other joiners???
# incr width [wcswidth_unclustered $g]
#}
} else {
incr width [wcswidth_unclustered $g]
}
set i $aftercluster
}
return $width
}
proc wcswidth_single {char} {
scan $c %c dec
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
return 1
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
return [textutil::wcswidth_char $c]
#may return -1 - REVIEW
}
return 0
}
proc wcswidth_unclustered1 {string} {
set width 0
foreach c [split $string {}] {
scan $c %c dec
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
return $width
}
#todo - consider disallowing/erroring out when \r \n in string?
# - tab/vtab?
# - compare with wcswidth returning -1 for entire string containing such in python,perl
proc wcswidth_unclustered {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?)
#Tcl initial evaluation stack size is 2000 (? review)
#we can only split the string at arbitrary points like this because we are specifically dealing with input that has no clusters!.
set chunksize 2000
set chunks_required [expr {int(ceil([tcl::string::length $string] / double($chunksize)))}]
set width 0
set startidx 0
set endidx [expr {$startidx + $chunksize -1}]
for {set i 0} {$i < $chunks_required} {incr i} {
set chunk [tcl::string::range $string $startidx $endidx]
set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]]
foreach c $codes {
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
incr startidx $chunksize
incr endidx $chunksize
}
return $width
}
# ------------------------------------------------------------------------------------------------------
proc wcswidth0 {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+
#TODO
@ -1943,20 +2163,6 @@ tcl::namespace::eval punk::char {
}
return $width
}
#faster than textutil::wcswidth (at least for string up to a few K in length)
proc wcswidth1 {string} {
set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]]
set width 0
foreach c $codes {
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
return $width
}
proc wcswidth2 {string} {
set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]]
set widths [lmap c $codes {textutil::wcswidth_char $c}]

1
src/bootsupport/modules/punk/console-0.1.1.tm

@ -875,6 +875,7 @@ namespace eval punk::console {
}
}
punk::args::set_alias punk::console::code_a+ punk::ansi::a+
proc code_a+ {args} {
variable ansi_wanted
if {$ansi_wanted <= 0} {

56
src/bootsupport/modules/punk/lib-0.1.1.tm

@ -962,21 +962,6 @@ namespace eval punk::lib {
namespace import ::punk::args::lib::tstr
#get info about punk nestindex key ie type: list,dict,undetermined
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
}
proc invoke command {
@ -1127,17 +1112,35 @@ namespace eval punk::lib {
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
-keysorttype -default "none" -choices {none dictionary ascii integer real}
-keysortdirection -default increasing -choices {increasing decreasing}
-debug -default 0 -type boolean -help\
"When enabled, produces some rudimentary debug output on stderr"
*values -min 1 -max -1
dictvalue -type list -help "dict or list value"
patterns -default "*" -type string -multiple 1 -help "key or key glob pattern"
}] $args]
#for punk::lib - we want to reduce pkg dependencies.
# - so we won't even use the tcllib debug pkg here
set opt_debug [dict get $argd opts -debug]
if {$opt_debug} {
if {[info body debug::showdict] eq ""} {
proc ::punk::lib::debug::showdict {args} {
catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"}
}
}
} else {
if {[info body debug::showdict] ne ""} {
proc ::punk::lib::debug::showdict {args} {}
}
}
set opt_sep [dict get $argd opts -separator]
set opt_mismatch_sep [dict get $argd opts -separator_mismatch]
set opt_keysorttype [dict get $argd opts -keysorttype]
set opt_keysortdirection [dict get $argd opts -keysortdirection]
set opt_trimright [dict get $argd opts -trimright]
set opt_keytemplates [dict get $argd opts -keytemplates]
puts stderr "---> $opt_keytemplates <---"
debug::showdict "keytemplates ---> $opt_keytemplates <---"
set opt_ansibase_keys [dict get $argd opts -ansibase_keys]
set opt_ansibase_values [dict get $argd opts -ansibase_values]
set opt_return [dict get $argd opts -return]
@ -4112,10 +4115,31 @@ tcl::namespace::eval punk::lib::system {
return $incomplete
}
#get info about punk nestindex key ie type: list,dict,undetermined
# pdict devel
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
#???
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
}
tcl::namespace::eval punk::lib::debug {
proc showdict {args} {}
}
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace

22
src/bootsupport/modules/punk/ns-0.1.0.tm

@ -1896,6 +1896,10 @@ tcl::namespace::eval punk::ns {
*id punk::ns::arginfo
*proc -name punk::ns::arginfo -help\
"Show usage info for a command"
-return -type string -default table -choices {string table tableobject}
-- -type none -help\
"End of options marker
Use this if the command to view begins with a -"
*values -min 1
commandpath -help\
"command (may be alias or ensemble)"
@ -2050,7 +2054,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$origin new"]
return [punk::args::usage {*}$opts "$origin new"]
}
create {
set constructorinfo [info class constructor $origin]
@ -2079,7 +2083,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$origin create"]
return [punk::args::usage {*}$opts "$origin create"]
}
destroy {
#review - generally no doc
@ -2092,7 +2096,7 @@ tcl::namespace::eval punk::ns {
*values -min 0 -max 0
}]
punk::args::definition $argspec
return [punk::args::usage "$origin destroy"]
return [punk::args::usage {*}$opts "$origin destroy"]
}
default {
#use info object call <obj> <method> to resolve callchain
@ -2112,7 +2116,7 @@ tcl::namespace::eval punk::ns {
set id "[string trimleft $origin :] $c1" ;# "<object> <method>"
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set def [::info object definition $origin $c1]
@ -2120,7 +2124,7 @@ tcl::namespace::eval punk::ns {
set id "[string trimleft $location :] $c1" ;# "<class> <method>"
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set def [::info class definition $location $c1]
@ -2162,7 +2166,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$location $c1"]
return [punk::args::usage {*}$opts "$location $c1"]
} else {
return "unable to resolve $origin method $c1"
}
@ -2216,7 +2220,7 @@ tcl::namespace::eval punk::ns {
}]
append argspec \n $vline
punk::args::definition $argspec
return [punk::args::usage $origin]
return [punk::args::usage {*}$opts $origin]
}
privateObject {
return "Command is a privateObject - no info currently available"
@ -2327,7 +2331,7 @@ tcl::namespace::eval punk::ns {
}]
append argspec \n $vline
punk::args::definition $argspec
return [punk::args::usage $origin]
return [punk::args::usage {*}$opts $origin]
}
#check for tepam help
@ -2363,7 +2367,7 @@ tcl::namespace::eval punk::ns {
set id [string trimleft $origin :]
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set origin_ns [nsprefix $origin]

2
src/bootsupport/modules/punk/repl/codethread-0.1.1.tm

@ -190,7 +190,7 @@ tcl::namespace::eval punk::repl::codethread {
if {[llength $::codeinterp::run_command_cache] > 2000} {
set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache]
}
if {[string first ":::" $::punk::ns::ns_current]} {
if {[string first ":::" $::punk::ns::ns_current] >= 0} {
#support for browsing 'odd' (inadvisable) namespaces
#don't use 'namespace exists' - will conflate ::test::x with ::test:::x
#if {$::punk::ns::ns_current in [namespace children [punk::ns::nsprefix $::punk::ns::ns_current]} {

225
src/bootsupport/modules/textblock-0.1.2.tm

@ -299,6 +299,9 @@ tcl::namespace::eval textblock {
#It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp.
#e.g $t configure -framemap_body [table_edge_map " "]
# -- --- --- --- ---
#unused?
proc table_edge_map {char} {
variable table_edge_parts
set map [list]
@ -335,6 +338,7 @@ tcl::namespace::eval textblock {
}
return $map
}
# -- --- --- --- ---
if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} {
#*** !doctools
@ -374,6 +378,7 @@ tcl::namespace::eval textblock {
variable o_columndefs
variable o_columndata
variable o_columnstates
variable o_headerdefs
variable o_headerstates
variable o_rowdefs
@ -432,6 +437,7 @@ tcl::namespace::eval textblock {
set o_columndefs [tcl::dict::create]
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_headerdefs [tcl::dict::create] ;#by header-row
set o_headerstates [tcl::dict::create]
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
@ -439,12 +445,14 @@ tcl::namespace::eval textblock {
set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices.
set o_calculated_column_widths [list]
set o_column_width_algorithm "span"
set header_defaults [tcl::dict::create\
set o_opts_header_defaults [tcl::dict::create\
-colspans {}\
-values {}\
-ansibase {}\
-ansireset "\x1b\[m"\
-minheight 1\
-maxheight ""\
]
set o_opts_header_defaults $header_defaults
}
method width_algorithm {{alg ""}} {
@ -1107,10 +1115,18 @@ tcl::namespace::eval textblock {
}
}
}
#args checked - ok to update headerstates and columndefs and columnstates
#args checked - ok to update headerstates, headerdefs and columndefs and columnstates
tcl::dict::set o_columndefs $cidx $checked_opts
set o_headerstates $hstates
dict for {hidx hstate} $hstates {
#configure_header
if {![dict exists $o_headerdefs $hidx]} {
#remove calculated members -values -colspans
set hdefaults [dict remove $o_opts_header_defaults -values -colspans]
dict set o_headerdefs $hidx $hdefaults
}
}
tcl::dict::set o_columnstates $cidx $colstate
if {$args_got_headers} {
@ -1267,11 +1283,10 @@ tcl::namespace::eval textblock {
return $hcolspans
}
#should be configure_headerrow ?
method configure_header {index_expression args} {
#*** !doctools
#[call class::table [method configure_header]]
#[para] - undocumented
#[para] - configure header row-wise
#the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs.
#It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis
@ -1279,7 +1294,7 @@ tcl::namespace::eval textblock {
set num_headers [my header_count_calc]
set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression]
if {$hidx eq ""} {
error "textblock::table::configure_header - no row defined at index '$hidx'."
error "textblock::table::configure_header - no header row defined at index '$index_expression'."
}
if {$hidx > $num_headers -1} {
#assert - shouldn't happen
@ -1298,6 +1313,14 @@ tcl::namespace::eval textblock {
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
}
tcl::dict::set result -values $header_row_items
#review - ensure always a headerdef record for each header?
if {[tcl::dict::exists $o_headerdefs $hidx]} {
set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]]
} else {
#warn for now
puts stderr "no headerdef record for header $hidx"
}
return $result
}
if {[llength $args] == 1} {
@ -1328,7 +1351,8 @@ tcl::namespace::eval textblock {
set colspans_by_header [my header_colspans]
set result [tcl::dict::create]
set val [tcl::dict::get $colspans_by_header $hidx]
set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"]
#ansireset not required
set returndict [tcl::dict::create option $k value $val]
}
-ansibase {
set val ???
@ -1369,8 +1393,7 @@ tcl::namespace::eval textblock {
lappend header_ansibase_items $code
}
}
set header_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items]
error "sorry - -ansibase not yet implemented for header rows"
set header_ansibase [punk::ansi::codetype::sgr_merge_singles $header_ansibase_items]
lappend checked_opts $k $header_ansibase
}
-ansireset {
@ -1472,6 +1495,10 @@ tcl::namespace::eval textblock {
#safe jumptable test
#dict for {k v} $checked_opts {}
#foreach {k v} $checked_opts {}
# headerdefs excludes -values and -colspans
set update_hdefs [tcl::dict::get $o_headerdefs $hidx]
tcl::dict::for {k v} $checked_opts {
switch -- $k {
-values {
@ -1538,8 +1565,28 @@ tcl::namespace::eval textblock {
incr c
}
}
default {
dict set update_hdefs $k $v
}
}
}
set opt_minh [tcl::dict::get $update_hdefs -minheight]
set opt_maxh [tcl::dict::get $update_hdefs -maxheight]
#todo - allow zero values to hide/collapse
# - see also configure_row
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
}
#set o_headerstate $hidx -minheight? -maxheight? ???
tcl::dict::set o_headerdefs $hidx $update_hdefs
}
method add_row {valuelist args} {
@ -2050,7 +2097,8 @@ tcl::namespace::eval textblock {
foreach header $header_list {
set headerspans [tcl::dict::get $all_colspans $hrow]
set this_span [lindex $headerspans $cidx]
set hval $ansibase_header$header ;#no reset
#set hval $ansibase_header$header ;#no reset
set hval $header
set rowh [my header_height $hrow]
if {$hrow == 0} {
@ -2317,7 +2365,7 @@ tcl::namespace::eval textblock {
set h_lines [lrepeat $rowh $bline]
set hcell_blank [::join $h_lines \n]
# -usecache 1 ok
#frame borders will never display - so use the simplest frametype and don't apply any ansi
#frame borders will never display - so use the simplest frametype and don't apply any ansi
#puts "===>zerospan hlims: $hlims"
set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\
-boxlimits $hlims -boxmap $framesub_map $hcell_blank\
@ -2589,8 +2637,8 @@ tcl::namespace::eval textblock {
}
}
set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body]
set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header]
#set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body]
#set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header]
#set header_underlay $ansibase_header$cell_line_blank
@ -2613,7 +2661,35 @@ tcl::namespace::eval textblock {
set showing_vseps [my Showing_vseps]
for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} {
set hdr [lindex $headerlist $hrow]
set header_maxdataheight [my header_height $hrow] ;#from cached headerstates
#jjj
set header_maxdataheight [tcl::dict::get $o_headerstates $hrow maxheightseen]
#set header_maxdataheight [my header_height $hrow] ;#from cached headerstates
set headerdefminh [tcl::dict::get $o_headerdefs $hrow -minheight]
set headerdefmaxh [tcl::dict::get $o_headerdefs $hrow -maxheight]
if {"$headerdefminh$headerdefmaxh" ne "" && $headerdefminh eq $headerdefmaxh} {
set headerh $headerdefminh ;#exact height defined for the row
} else {
if {$headerdefminh eq ""} {
if {$headerdefmaxh eq ""} {
#both defs empty
set headerh $header_maxdataheight
} else {
set headerh [expr {min(1,$headerdefmaxh,$header_maxdataheight)}]
}
} else {
if {$headerdefmaxh eq ""} {
set headerh [expr {max($headerdefminh,$header_maxdataheight)}]
} else {
if {$header_maxdataheight < $headerdefminh} {
set headerh $headerdefminh
} else {
set headerh [expr {max($headerdefminh,$header_maxdataheight)}]
}
}
}
}
set headerrow_colspans [tcl::dict::get $all_colspans $hrow]
set this_span [lindex $headerrow_colspans $cidx]
@ -2654,8 +2730,7 @@ tcl::namespace::eval textblock {
set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight]
set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight]
if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} {
#an exact height is defined for the row
set rowh $rowdefminh
set rowh $rowdefminh ;#an exact height is defined for the row
} else {
if {$rowdefminh eq ""} {
if {$rowdefmaxh eq ""} {
@ -2814,6 +2889,7 @@ tcl::namespace::eval textblock {
$t destroy
}
puts stdout "columnstates: $o_columnstates"
puts stdout "headerdefs: $o_headerdefs"
puts stdout "headerstates: $o_headerstates"
tcl::dict::for {k coldef} $o_columndefs {
if {[tcl::dict::exists $o_columndata $k]} {
@ -4205,6 +4281,68 @@ tcl::namespace::eval textblock {
return $t
}
proc bookend_lines {block start {end "\x1b\[m"}} {
set out ""
foreach ln [split $block \n] {
append out $start $ln $end \n
}
return [string range $out 0 end-1]
}
proc ansibase_lines {block {newprefix ""}} {
set base ""
set out ""
if {$newprefix eq ""} {
foreach ln [split $block \n] {
set parts [punk::ansi::ta::split_codes $ln]
if {[lindex $parts 0] eq ""} {
if {[lindex $parts 1] ne "" && ![punk::ansi::codetype::is_sgr_reset [lindex $parts 1]]} {
set base [lindex $parts 1]
append out $base
} else {
append out $base
}
} else {
#leading plaintext - maintain our base
append out $base [lindex $parts 0] [lindex $parts 1]
}
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]
}
incr code_idx 2
}
append out {*}[lrange $parts 2 end] \n
}
return [string range $out 0 end-1]
} else {
set base $newprefix
foreach ln [split $block \n] {
set parts [punk::ansi::ta::split_codes $ln]
set code_idx 1
set offset 0
foreach {pt code} $parts {
if {$code_idx == 1} {
#first pt & code
if {$pt ne ""} {
#leading plaintext
set parts [linsert $parts 0 $base]
incr offset
}
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts [expr {$code_idx+1+$offset}] $base]
incr offset
}
incr code_idx 2
}
append out {*}$parts \n
}
return [string range $out 0 end-1]
}
}
set FRAMETYPES [textblock::frametypes]
punk::args::definition [punk::lib::tstr -return string {
*id textblock::list_as_table
@ -4606,12 +4744,22 @@ tcl::namespace::eval textblock {
return [punk::char::ansifreestring_width $tl]
}
#uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function.
proc string_length_line_max textblock {
tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
proc string_length_line_max {textblock} {
#tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
set max 0
foreach ln [split $textblock \n] {
if {[tcl::string::length $ln] > $max} {set max [tcl::string::length $ln]}
}
return $max
}
#*slightly* slower
#proc string_length_line_max {textblock} {
# tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
#}
proc string_length_line_min textblock {
tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
}
proc height {textblock} {
#This is the height as it will/would-be rendered - not the number of input lines purely in terms of le
#empty string still has height 1 (at least for left-right/right-left languages)
@ -4652,6 +4800,45 @@ tcl::namespace::eval textblock {
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size2 {textblock} {
if {$textblock eq ""} {
return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack
if {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
set lines [split $textblock \n]
set num_le [expr {[llength $lines]-1}]
#set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]]
set width 0
foreach ln $lines {
set w [::punk::char::ansifreestring_width $ln]
if {$w > $width} {
set width $w
}
}
} else {
set num_le 0
set width [punk::char::ansifreestring_width $textblock]
}
#set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list
#our concept of block-height is likely to be different to other line-counting mechanisms
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size_as_opts {textblock} {
set sz [size $textblock]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]

42
src/doc/_module_termscheme-0.1.0.tm.man

@ -0,0 +1,42 @@
[comment {--- punk::docgen generated from inline doctools comments ---}]
[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]
[comment {--- punk::docgen overwrites this file ---}]
[manpage_begin shellspy_module_termscheme 0 0.1.0]
[copyright "2024"]
[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
[moddesc {-}] [comment {-- Description at end of page heading --}]
[require termscheme]
[keywords module]
[description]
[para] -
[section Overview]
[para] overview of termscheme
[subsection Concepts]
[para] -
[subsection dependencies]
[para] packages used by termscheme
[list_begin itemized]
[item] [package {Tcl 8.6}]
[list_end]
[section API]
[subsection {Namespace termscheme::class}]
[para] class definitions
if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
[list_begin enumerated]
[list_end] [comment {--- end class enumeration ---}]
}
}
++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
[subsection {Namespace termscheme}]
[para] Core API functions for termscheme
[list_begin definitions]
[list_end] [comment {--- end definitions namespace termscheme ---}]
[subsection {Namespace termscheme::lib}]
[para] Secondary functions that are part of the API
[list_begin definitions]
[list_end] [comment {--- end definitions namespace termscheme::lib ---}]
[section Internal]
tcl::namespace::eval termscheme::system {
[subsection {Namespace termscheme::system}]
[para] Internal functions that are not part of the API
[manpage_end]

2
src/doc/punk/_module_ansi-0.1.1.tm.man

@ -136,7 +136,7 @@ tput rmam
[call [fun ansistrip] [arg text] ]
[para]Return a string with ansi codes stripped out
[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs)
[call [fun ansistrip] [arg text] ]
[call [fun ansistrip2] [arg text] ]
[para]Return a string with ansi codes stripped out
[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs)
[call [fun ansistripraw] [arg text] ]

20
src/doc/punk/_module_args-0.1.0.tm.man

@ -37,7 +37,7 @@
#setting -type none indicates a flag that doesn't take a value (solo flag)
-nocomplain -type none
*values -min 1 -max -1
} $args]] opts values
} $args]] leaders opts values
puts "translation is [dict get $opts -translation]"
foreach f [dict values $values] {
@ -47,7 +47,7 @@
}]
[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls
[para] - the above example would work just fine with only the -<optionname> lines, but would allow zero filenames to be supplied as no -min value is set for *values
[para]valid * lines being with *proc *opts *values
[para]valid * lines being with *proc *leaders *opts *values
[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument.
[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero.
[para]e.g the result from the punk::args call above may be something like:
@ -63,7 +63,7 @@
*values -min 2 -max 2
fileA -type existingfile 1
fileB -type existingfile 1
} $args]] opts values
} $args]] leaders opts values
puts "$category fileA: [dict get $values fileA]"
puts "$category fileB: [dict get $values fileB]"
}
@ -164,14 +164,16 @@ For functions that are part of an API a package may be more suitable.
[item] [package {Tcl 8.6-}]
[list_end]
[section API]
[subsection {Namespace punk::args::class}]
[para] class definitions
[list_begin enumerated]
[list_end] [comment {--- end class enumeration ---}]
[subsection {Namespace punk::args}]
[para] cooperative namespace punk::args::register
[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded
[para] The punk::args package will then test for a public list variable <namepace>::PUNKARGS containing argument definitions when it needs to.
[list_begin definitions]
[list_end] [comment {--- end definitions namespace punk::args::register ---}]
[subsection {Namespace punk::args}]
[para] Core API functions for punk::args
[list_begin definitions]
[call [fun get_dict] [arg optionspecs] [arg rawargs] [opt {option value...}]]
[call [fun get_dict] [arg optionspecs] [arg rawargs]]
[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values
[para]Returns a dict of the form: opts <options_dict> values <values_dict>
[para]ARGUMENTS:
@ -186,7 +188,7 @@ For functions that are part of an API a package may be more suitable.
[para]argumentname -key val -ky2 val2...
[para]where the valid keys for each option specification are: -default -type -range -choices
[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value
[para]lines beginning with *proc *opts or *values also take -key val pairs and can be used to set defaults and control settings.
[para]lines beginning with *proc *leaders *opts or *values also take -key val pairs and can be used to set defaults and control settings.
[para]*opts or *values lines can appear multiple times with defaults affecting flags/values that follow.
[arg_def list rawargs]
[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc,

2
src/doc/punk/_module_console-0.1.1.tm.man

@ -17,7 +17,9 @@
[para] packages used by punk::console
[list_begin itemized]
[item] [package {Tcl 8.6-}]
[item] [package {Thread}]
[item] [package {punk::ansi}]
[item] [package {punk::args}]
[list_end]
[section API]
[subsection {Namespace punk::console}]

1
src/doc/punk/_module_lib-0.1.1.tm.man

@ -20,6 +20,7 @@
[para] packages used by punk::lib
[list_begin itemized]
[item] [package {Tcl 8.6-}]
[item] [package {punk::args}]
[list_end]
[section API]
[subsection {Namespace punk::lib::compat}]

43
src/doc/punk/_module_safe-0.1.0.tm.man

@ -0,0 +1,43 @@
[comment {--- punk::docgen generated from inline doctools comments ---}]
[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]
[comment {--- punk::docgen overwrites this file ---}]
[manpage_begin punkshell_module_punk::safe 0 0.1.0]
[copyright "2024"]
[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
[moddesc {punk::safe - safebase interpreters}] [comment {-- Description at end of page heading --}]
[require punk::safe]
[keywords module]
[description]
[para] -
[section Overview]
[para] overview of punk::safe
[subsection Concepts]
[para] -
[subsection dependencies]
[para] packages used by punk::safe
[list_begin itemized]
[item] [package {Tcl 8.6}]
[item] [package {punk::args}]
[list_end]
[section API]
[subsection {Namespace punk::safe::class}]
[para] class definitions
if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
[list_begin enumerated]
[list_end] [comment {--- end class enumeration ---}]
}
}
++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
[subsection {Namespace punk::safe::lib}]
[para] Secondary functions that are part of the API
[list_begin definitions]
[list_end] [comment {--- end definitions namespace punk::safe::lib ---}]
[subsection {Namespace punk::safe}]
[para] Core API functions for punk::safe
[list_begin definitions]
[call [fun setSyncMode] [arg args]]
[list_end] [comment {--- end definitions namespace punk::safe ---}]
[section Internal]
[subsection {Namespace punk::safe::system}]
[para] Internal functions that are not part of the API
[manpage_end]

42
src/doc/punk/_module_sixel-0.1.0.tm.man

@ -0,0 +1,42 @@
[comment {--- punk::docgen generated from inline doctools comments ---}]
[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]
[comment {--- punk::docgen overwrites this file ---}]
[manpage_begin punkshell_module_punk::sixel 0 0.1.0]
[copyright "2024"]
[titledesc {punk::sixel API}] [comment {-- Name section and table of contents description --}]
[moddesc {experimental sixel functions}] [comment {-- Description at end of page heading --}]
[require punk::sixel]
[keywords module experimental]
[description]
[para] Experimental support functions for working with sixel data
[para] For real sixel work a version written in a systems language such as c or zig may be required.
[section Overview]
[para] overview of punk::sixel
[subsection Concepts]
[para] -
[subsection dependencies]
[para] packages used by punk::sixel
[list_begin itemized]
[item] [package {Tcl 8.6}]
[item] [package {punk::args}]
[item] [package {punk::console}]
[item] [package {punk::ansi}]
[list_end]
[section API]
[subsection {Namespace punk::sixel::class}]
[para] class definitions
if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
[list_begin enumerated]
[list_end] [comment {--- end class enumeration ---}]
}
}
++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
[subsection {Namespace punk::sixel}]
[para] Core API functions for punk::sixel
[list_begin definitions]
[list_end] [comment {--- end definitions namespace punk::sixel ---}]
[subsection {Namespace punk::sixel::lib}]
[para] Secondary functions that are part of the API
[list_begin definitions]
[list_end] [comment {--- end definitions namespace punk::sixel::lib ---}]
[manpage_end]

43
src/doc/punk/args/_module_tclcore-0.1.0.tm.man

@ -0,0 +1,43 @@
[comment {--- punk::docgen generated from inline doctools comments ---}]
[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]
[comment {--- punk::docgen overwrites this file ---}]
[manpage_begin punkshell_module_punk::args::tclcore 0 0.1.0]
[copyright "2025"]
[titledesc {punk::args definitions for tcl core commands}] [comment {-- Name section and table of contents description --}]
[moddesc {tcl core argument definitions}] [comment {-- Description at end of page heading --}]
[require punk::args::tclcore]
[keywords module]
[description]
[para] -
[section Overview]
[para] overview of punk::args::tclcore
[subsection Concepts]
[para] -
[subsection dependencies]
[para] packages used by punk::args::tclcore
[list_begin itemized]
[item] [package {Tcl 8.6}]
[item] [package {punk::args}]
[list_end]
[section API]
[subsection {Namespace punk::args::tclcore::class}]
[para] class definitions
if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
[list_begin enumerated]
[list_end] [comment {--- end class enumeration ---}]
}
}
++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
[subsection {Namespace punk::args::tclcore}]
[para] Core API functions for punk::args::tclcore
[list_begin definitions]
[list_end] [comment {--- end definitions namespace punk::args::tclcore ---}]
[subsection {Namespace punk::args::tclcore::lib}]
[para] Secondary functions that are part of the API
[list_begin definitions]
[list_end] [comment {--- end definitions namespace punk::args::tclcore::lib ---}]
[section Internal]
tcl::namespace::eval punk::args::tclcore::system {
[subsection {Namespace punk::args::tclcore::system}]
[para] Internal functions that are not part of the API
[manpage_end]

2
src/doc/punk/nav/_module_fs-0.1.0.tm.man

@ -1,7 +1,7 @@
[comment {--- punk::docgen generated from inline doctools comments ---}]
[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]
[comment {--- punk::docgen overwrites this file ---}]
[manpage_begin shellspy_module_punk::nav::fs 0 0.1.0]
[manpage_begin punkshell_module_punk::nav::fs 0 0.1.0]
[copyright "2024"]
[titledesc {punk::nav::fs console filesystem navigation}] [comment {-- Name section and table of contents description --}]
[moddesc {fs nav}] [comment {-- Description at end of page heading --}]

6
src/doc/punk/repl/_module_codethread-0.1.0.tm.man

@ -1,7 +1,7 @@
[comment {--- punk::docgen generated from inline doctools comments ---}]
[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]
[comment {--- punk::docgen overwrites this file ---}]
[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0]
[manpage_begin punkshell_module_punk::repl::codethread 0 0.1.0]
[copyright "2024"]
[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}]
[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}]
@ -21,12 +21,8 @@
[section API]
[subsection {Namespace punk::repl::codethread::class}]
[para] class definitions
if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} {
[list_begin enumerated]
[list_end] [comment {--- end class enumeration ---}]
}
}
++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
[subsection {Namespace punk::repl::codethread}]
[para] Core API functions for punk::repl::codethread
[list_begin definitions]

37
src/doc/punk/repl/_module_codethread-0.1.1.tm.man

@ -0,0 +1,37 @@
[comment {--- punk::docgen generated from inline doctools comments ---}]
[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]
[comment {--- punk::docgen overwrites this file ---}]
[manpage_begin punkshell_module_punk::repl::codethread 0 0.1.1]
[copyright "2024"]
[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}]
[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}]
[require punk::repl::codethread]
[keywords module repl]
[description]
[para] This is part of the infrastructure required for the punk::repl to operate
[section Overview]
[para] overview of punk::repl::codethread
[subsection Concepts]
[para] -
[subsection dependencies]
[para] packages used by punk::repl::codethread
[list_begin itemized]
[item] [package {Tcl 8.6}]
[list_end]
[section API]
[subsection {Namespace punk::repl::codethread::class}]
[para] class definitions
[list_begin enumerated]
[list_end] [comment {--- end class enumeration ---}]
[subsection {Namespace punk::repl::codethread}]
[para] Core API functions for punk::repl::codethread
[list_begin definitions]
[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}]
[subsection {Namespace punk::repl::codethread::lib}]
[para] Secondary functions that are part of the API
[list_begin definitions]
[list_end] [comment {--- end definitions namespace punk::repl::codethread::lib ---}]
[section Internal]
[subsection {Namespace punk::repl::codethread::system}]
[para] Internal functions that are not part of the API
[manpage_end]

164
src/modules/punk-0.1.tm

@ -101,12 +101,15 @@ set punk_testd2 [dict create \
] \
]
#impolitely cooperative withe punk repl - todo - tone it down.
#impolitely cooperative with punk repl - todo - tone it down.
#namespace eval ::punk::repl::codethread {
# variable running 0
#}
package require punk::lib
package require punk::lib ;# subdependency punk::args
package require punk::ansi
if {![llength [info commands ::ansistring]]} {
namespace import punk::ansi::ansistring
}
#require aliascore after punk::lib & punk::ansi are loaded
package require punk::aliascore ;#mostly punk::lib aliases
punk::aliascore::init
@ -114,9 +117,6 @@ punk::aliascore::init
package require punk::repl::codethread
package require punk::config
#package require textblock
if {![llength [info commands ::ansistring]]} {
namespace import punk::ansi::ansistring
}
package require punk::console
package require punk::ns
package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems
@ -862,6 +862,8 @@ namespace eval punk {
}
}
#? {
#review - compare to %# ?????
#seems to be unimplemented ?
set assigned [string length $leveldata]
set already_assigned 1
}
@ -7149,12 +7151,93 @@ namespace eval punk {
dict filter $result value {?*}
}
punk::args::definition {
*id punk::inspect
*proc -name punk::inspect -help\
"Function to display values - used pimarily in a punk pipeline.
The raw value arguments (not options) are always returned to pass
forward in the pipeline.
(pipeline data inserted at end of each |...> segment is passed as single item unless
inserted with an expanding insertion specifier such as .=>* )
e.g1:
.= list a b c |v1,/1-end,/0>\\
.=>* inspect -label i1 -- |>\\
.=v1> inspect -label i2 -- |>\\
string toupper
(3) i1: {a b c} {b c} a
(1) i2: a b c
- A B C
"
-label -type string -default "" -help\
"An optional label to help distinguish output when multiple
inspect statements are in a pipeline. This appears after the
bracketed count indicating number of values supplied.
e.g (2) MYLABEL: val1 val2
The label can include ANSI codes.
e.g
inspect -label [a+ red]mylabel -- val1 val2 val3
"
-limit -type int -default 20 -help\
"When multiple values are passed to inspect - limit the number
of elements displayed in -channel output.
When truncation has occured an elipsis indication (...) will be appended.
e.g
.= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+
(11) 20 23 26 29...
- 385
For no limit - use -limit -1
"
-channel -type string -default stderr -help\
"An existing open channel to write to. If value is any of nul, null, /dev/nul
the channel output is disabled. This effectively disables inspect as the args
are simply passed through in the return to continue the pipeline.
"
-showcount -type boolean -default 1 -help\
"Display a leading indicator in brackets showing the number of arg values present."
-ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels {
0 "Strip ANSI codes from display
of values. The disply output will
still be colourised if -ansibase has
not been set to empty string or
[a+ normal]. The stderr or stdout
channels may also have an ansi colour.
(see 'colour off' or punk::config)"
1 "Leave value as is"
2 "Display the ANSI codes and
other control characters inline
with replacement indicators.
e.g esc, newline, space, tab"
VIEW "Alias for 2"
3 "Display as per 2 but with
colourised ANSI replacement codes."
VIEWCODES "Alias for 3"
4 "Display ANSI and control
chars in default colour, but
apply the contained ansi to
the text portions so they display
as they would for -ansi 1"
VIEWSTYLE "Alias for 4"
}
-ansibase -type ansistring -default {${[a+ brightgreen]}} -help\
"Base ansi code(s) that will apply to output written to the chosen -channel.
If there are ansi resets in the displayed values - output will revert to this base.
Does not affect return value."
-- -type none -help\
"End of options marker.
It is advisable to use this, as data in a pipeline may often begin with -"
*values -min 0 -max -1
arg -type string -optional 1 -multiple 1 -help\
"value to display"
}
#pipeline inspect
#e.g
#= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data}
proc inspect {args} {
set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1]
set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1 -ansibase [a+ brightgreen]]
set flags [list]
set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect --
if {$endoptsposn >= 0} {
@ -7177,24 +7260,28 @@ namespace eval punk {
}
foreach {k v} $flags {
if {$k ni [dict keys $defaults]} {
error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --"
#error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --"
punk::args::get_by_id punk::inspect $args
}
}
set opts [dict merge $defaults $flags]
# -- --- --- --- ---
set label [dict get $opts -label]
set channel [dict get $opts -channel]
set showcount [dict get $opts -showcount]
set label [dict get $opts -label]
set channel [dict get $opts -channel]
set showcount [dict get $opts -showcount]
if {[string length $label]} {
set label "${label}: "
}
set limit [dict get $opts -limit]
set opt_ansi [dict get $opts -ansi]
set opt_ansiraw [dict get $opts -ansi]
set opt_ansi [tcl::prefix::match -error "" [list 0 1 2 3 4 view viewcodes viewstyle] [string tolower $opt_ansiraw]]
switch -- [string tolower $opt_ansi] {
0 - 1 - 2 {}
view {set opt_ansi 2}
0 - 1 - 2 - 3 - 4 {}
view {set opt_ansi 2}
viewcodes {set opt_ansi 3}
viewstyle {set opt_ansi 4}
default {
error "inspect -ansi 0|1|2|view - received -ansi $opt_ansi"
error "inspect -ansi 0|1|2|view|3|viewcodes|4|viewstyle - received -ansi $opt_ansiraw"
}
}
# -- --- --- --- ---
@ -7248,15 +7335,50 @@ namespace eval punk {
} else {
set displaycount ""
}
if {$opt_ansi == 0} {
set displayval [punk::ansi::ansistrip $displayval]
} elseif {$opt_ansi == 2} {
set displayval [ansistring VIEW $displayval]
set ansibase [dict get $opts -ansibase]
if {$ansibase ne ""} {
#-ansibase default is hardcoded into punk::args definition
#run a test using any ansi code to see if colour is still enabled
if {[a+ red] eq ""} {
set ansibase "" ;#colour seems to be disabled
}
}
switch -- $opt_ansi {
0 {
set displayval $ansibase[punk::ansi::ansistrip $displayval]
}
1 {
#val may have ansi - including resets. Pass through ansibase_lines to
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
2 {
set displayval $ansibase[ansistring VIEW $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
3 {
set displayval $ansibase[ansistring VIEWCODE $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
4 {
set displayval $ansibase[ansistring VIEWSTYLE $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
}
if {![string length $more]} {
puts $channel "$displaycount$label[a green bold]$displayval[a]"
puts $channel "$displaycount$label$displayval[a]"
} else {
puts $channel "$displaycount$label[a green bold]$displayval[a yellow bold]$more[a]"
puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]"
}
return $val
}

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

@ -167,6 +167,7 @@ tcl::namespace::eval punk::ansi::class {
}
default {
puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x"
punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args
}
}
}
@ -2415,6 +2416,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
*id punk::ansi::a+
*proc -name "punk::ansi::a+" -help\
"Returns an ANSI sgr escape sequence based on the list of supplied codes.
Unlike punk::ansi::a - it is not prefixed with an ANSI reset.
"
*values -min 0 -max -1
} [string map [list <choices> [dict keys $SGR_map]] {
@ -2432,10 +2434,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
The acceptable values for <termcolour> and <webcolour> can be queried using
punk::ansi::a? term
and
punk::ansi::a? web"
punk::ansi::a? web
Example to set foreground red and background cyan followed by a reset:
set str \"[a+ red Cyan]sample text[a]\"
"
}]]
proc a+ {args} {
#*** !doctools
#[call [fun a+] [opt {ansicode...}]]
@ -7065,13 +7069,12 @@ tcl::namespace::eval punk::ansi::ansistring {
}
}
#inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi
#todo - document
interp alias {} ansistring {} ::punk::ansi::ansistring
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}]
}
tcl::namespace::eval punk::ansi::control {
proc APC {args} {
return \x1b_[join $args {;}]\x1b\\
@ -7393,6 +7396,10 @@ tcl::namespace::eval punk::ansi::internal {
}
}
#inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi
#todo - document
interp alias {} ansistring {} ::punk::ansi::ansistring
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set NAMESPACES [list]

87
src/modules/punk/args-999999.0a1.0.tm

@ -353,7 +353,7 @@ tcl::namespace::eval punk::args {
}
set optionspecs [join $normargs \n]
if {[string first \$\{ $optionspecs] > 0} {
set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 $optionspecs]]
set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]]
}
} else {
if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} {
@ -1262,30 +1262,43 @@ tcl::namespace::eval punk::args {
if {$arg_error_isrunning} {
error "arg_error already running - error in arg_error?\n triggering errmsg: $msg"
}
set arg_error_isrunning 1
if {[llength $args] %2 != 0} {
error "error in arg_error processing - expected opt/val pairs after msg and spec_dict"
}
set arg_error_isrunning 1
set badarg ""
set returntype error
set returntype table ;#table as string
set as_error 1 ;#usual case is to raise an error
dict for {k v} $args {
switch -- $k {
-badarg {
set badarg $v
}
-aserror {
if {![string is boolean -strict $v]} {
set arg_error_isrunning 0
error "arg_error invalid value for option -aserror. Received '$v' expected a boolean"
}
set as_error $v
}
-return {
if {$v ni {error string}} {
error "arg_error invalid value for option -return. Received '$v' expected one of: error string"
if {$v ni {string table tableobject}} {
set arg_error_isrunning 0
error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject"
}
set returntype $v
}
default {
set arg_error_isrunning 0
error "arg_error invalid option $k. Known_options: -badarg -return"
}
}
}
set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist.
#REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error
#e.g list_as_table
@ -1300,12 +1313,20 @@ tcl::namespace::eval punk::args {
#couldn't load textblock package
#just return the original errmsg without formatting
}
set use_table 0
if {$has_textblock && $returntype in {table tableobject}} {
set use_table 1
}
set errlines [list] ;#for non-textblock output
if {[catch {
if {$has_textblock} {
if {$use_table} {
append errmsg \n
} else {
append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n
if {($returntype in {table tableobject}) && !$has_textblock} {
append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n
} else {
append errmsg \n
}
}
set procname [Dict_getdef $spec_dict proc_info -name ""]
set prochelp [Dict_getdef $spec_dict proc_info -help ""]
@ -1333,7 +1354,7 @@ tcl::namespace::eval punk::args {
} else {
set docurl_display ""
}
if {$has_textblock} {
if {$use_table} {
set t [textblock::class::table new [a+ brightyellow]Usage[a]]
$t add_column -headers $blank_header_col -minwidth 3
$t add_column -headers $blank_header_col
@ -1343,7 +1364,7 @@ tcl::namespace::eval punk::args {
}
set h 0
if {$procname ne ""} {
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display]
} else {
lappend errlines "PROC/METHOD: $procname_display"
@ -1351,7 +1372,7 @@ tcl::namespace::eval punk::args {
incr h
}
if {$prochelp ne ""} {
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list Description: $prochelp_display]
} else {
lappend errlines "Description: $prochelp_display"
@ -1362,14 +1383,14 @@ tcl::namespace::eval punk::args {
if {![catch {package require punk::ansi}]} {
set docurl [punk::ansi::hyperlink $docurl]
}
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list $docname $docurl_display]
} else {
lappend errlines "$docname $docurl_display"
}
incr h
}
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -values {Arg Type Default Multi Help}
} else {
lappend errlines " --ARGUMENTS-- "
@ -1519,7 +1540,7 @@ tcl::namespace::eval punk::args {
set numcols [llength $formattedchoices]
}
if {$numcols > 0} {
if {$has_textblock} {
if {$use_table} {
#risk of recursing
set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices]
append help \n[textblock::join -- " " $choicetable]
@ -1565,7 +1586,7 @@ tcl::namespace::eval punk::args {
append typeshow \n "-range [dict get $arginfo -range]"
}
if {$has_textblock} {
if {$use_table} {
$t add_row [list $argshow $typeshow $default $multiple $help]
if {$arg eq $badarg} {
$t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG
@ -1577,11 +1598,14 @@ tcl::namespace::eval punk::args {
}
}
if {$has_textblock} {
if {$use_table} {
$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow]
$t configure -maxwidth 80
$t configure -maxwidth 80 ;#review
append errmsg [$t print]
$t destroy
if {$returntype ne "tableobject"} {
#returntype of table means just the text of the table
$t destroy
}
} else {
append errmsg [join $errlines \n]
}
@ -1595,11 +1619,22 @@ tcl::namespace::eval punk::args {
}
set arg_error_isrunning 0
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
if {$returntype eq "error"} {
return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg
#Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
if {$use_table} {
#assert returntype is one of table, tableobject
set result $errmsg ;#default if for some reason table couldn't be used
if {$returntype eq "tableobject"} {
if {[info object isa object $t]} {
set result $t
}
}
} else {
return $errmsg
set result $errmsg
}
if {$as_error} {
return -code error -errorcode {TCL WRONGARGS PUNK} $result
} else {
return $result
}
}
@ -1609,17 +1644,21 @@ tcl::namespace::eval punk::args {
*proc -name punk::args::usage -help\
"return usage information as a string
in table form."
-return -default table -choices {string table tableobject}
*values -min 0 -max 1
id -help\
"exact id.
Will usually match the command name"
}]
proc usage {id} {
proc usage {args} {
lassign [dict values [punk::args::get_by_id punk::args::usage $args]] leaders opts values received
set id [dict get $values id]
set speclist [get_spec $id]
if {[llength $speclist] == 0} {
error "punk::args::usage - no such id: $id"
}
arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] -return string
arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] {*}$opts -aserror 0
}
lappend PUNKARGS [list {
@ -2726,7 +2765,7 @@ tcl::namespace::eval punk::args::lib {
*id punk::args::lib::tstr
*proc -name punk::args::lib::tstr -help\
"A rough equivalent of js template literals"
-allowcommands -default -1 -type none -help\
-allowcommands -default 0 -type none -help\
"if -allowcommands is present, placeholder can contain commands e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}"
-return -default list -choices {dict list string args}\
-choicelabels {

65
src/modules/punk/args/tclcore-999999.0a1.0.tm

@ -198,12 +198,58 @@ tcl::namespace::eval punk::args::tclcore {
The handler is invoked when a command called from within the namespace cannot
be found in the current namespace, the namespace's path nor in the global
namespace.
"
When the handler is invoiked, the full invocation line will be appended to
the script and the result evaluated in the context of the namespace.
The default handler for all namespaces is [a+ italic]::unknown[a].
If no argument is given, it returns the handler for the current namespace."
*values -min 0 -max 1
script -type script -optional 1 -help\
"A well formed list representing a command name and "
"A well formed list representing a command name and optional arguments."
} "*doc -name Manpage: -url [manpage_tcl namespace]" ]
set I [a+ italic]
set NI [a+ noitalic]
lappend PUNKARGS [list {
*id tcl::process::status
*proc -name "Builtin: tcl::process::status" -help\
"Returns a dictionary mapping subprocess PIDs to their respective status.
if ${$I}pids${$NI} is specified as a list of PIDs then the command
only returns the status of the matching subprocesses if they exist, and
raises an error otherwise.
For active processes, the status is an empty value. For terminated
processes, the status is a list with the following format:
{code ?msg errorCode?}
where:
${$I}code${$NI}
is a standard Tcl return code, ie.,
0 for TCL_OK and 1 for TCL_ERROR,
${$I}msg${$NI}
is the human readable error message,
${$I}errorCode${$NI}
uses the same format as the errorCode global variable
Note that msg and errorCode are only present for abnormally
terminated processes (i.e. those where the code is nonzero).
Under the hood this command calls Tcl_WaitPid with the
WNOHANG flag set for non-blocking behaviour, unless the -wait
switch is set (see below).
"
-wait -type none -optional 1 -help\
"By default the command returns immediately (the underlying Tcl_WaitPid
is called with the WNOHANG flag set) unless this switch is set. if pids
is specified as a list of PIDS then the command waits until the status
of the matching subprocesses are avaliable. If pids was not specified,
this command will wait for all known subprocesses."
-- -type none -optional 1 -help\
"Marks the end of switches. The argument following this one will be
treated as the first arg even if it starts with a -."
*values -min 0 -max 1
pids -type list -optional 1 -help\
"A list of PIDs"
} "*doc -name Manpage: -url [manpage_tcl namespace]" ]
lappend PUNKARGS [list {
*id lappend
*proc -name "builtin: lappend" -help\
@ -613,13 +659,6 @@ tcl::namespace::eval punk::args::tclcore {
string -type string -optional 0
}] "*doc -name Manpage: -url [manpage_tcl string]"
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
}
}
lappend ::punk::args::register::NAMESPACES ::punk::args::tclcore
#*** !doctools
#[subsection {Namespace punk::args::tclcore}]
#[para] Core API functions for punk::args::tclcore
@ -687,6 +726,14 @@ tcl::namespace::eval punk::args::tclcore::lib {
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
}
}
lappend ::punk::args::register::NAMESPACES ::punk::args::tclcore
## Ready
package provide punk::args::tclcore [tcl::namespace::eval punk::args::tclcore {
variable pkg punk::args::tclcore

248
src/modules/punk/char-999999.0a1.0.tm

@ -600,6 +600,48 @@ tcl::namespace::eval punk::char {
puts stdout \n
puts stdout "cursor position immediately after outputing 3 bytes (xyz): $cursorposn"
}
proc test_zalgo {} {
#from: https://github.com/jameslanska/unicode-display-width/blob/5e28d94c75e8c421a87199363b85c90dc37125b8/docs/unicode_background.md
#see: https://lingojam.com/ZalgoText
puts stdout "44 chars long - 9 graphemes - 9 columns wide"
set str "Ẓ̌á̲l͔̝̞̄̑͌g̖̘̘̔̔͢͞͝o̪̔T̢̙̫̈̍͞e̬͈͕͌̏͑x̺̍̓̓ͅ"
}
proc test_zalgo2 {} {
# ------------------------
set str "Z̸̢͉̣͔̭̪͙̖̳̘͈͍̤̩̟͈͈͕̯̅̏̆̓̌́́͌̿̕ͅą̷̦̤̫̩͕̥̐̎̓́́̂̀͆́̔̄̈́̏̌́̆͜͜͝͠l̴̩̙̺͚̟͇͖͔͕̹̟͌̈́̄̇́̉̋̕̚͜͠͠g̸͇̩͔̺̝̗̥̖̙̑̈́̈́̿̾̌͌͊̈̀͊̑̇̑͌̍̅̌͊͜͠͝ǫ̴̢̧͎͔̞̤̻̱̮̬͕̗̭͍̣̠̳̆̀̋̓͒̾̄͜͝͠͝T̴̛͉̬̋́̈́̈́̓͗̍̏̔̈̋̀͐̓̎̅̚̕͠͝͝ê̵̖̖̈͊̔̓̔̐̓̃͊̋͋̎͂͋̕x̴̡͎͖̼͎̦͎̲̪̘̺̯̲̬̮̥̼̰͌̃͜ͅt̶̛̘͎̰̔͐͌́̈́͊͗͌̅͂̐̆͌̀͂͘"
# ------------------------
}
proc test_zalgo3 {} {
# ------------------------
set str "Ẕ̸̢̼̺̜̰̣̣̖̭̜͓͖̺̥̼̠͙͙̟̥̟̠̤̫͍̠̤̮͚̝̜̙͈̦̙̩̹̙̜̩̦͔͕̈̃̅̇̈́͂̇̽̈́́́́̎͊̂̑̋͆̔̾͋̚͜ͅã̵̛̪̽̎̃͑̒̇͋͂̽̃̍͊̀̈̊̊̔̊̆̈́͗͑͗̽̄̋͗̄͌̑͊͝͝͠ͅl̵̢͇̖͉͖̝̹̜̞͓͎͍͈̞̱̙͙̦̪͔̱̮͈͉̼͎̭̝̯͇͚̺̟̱͙̳̰̙͚͖̝̫͙̎̅̃͆̈́̋̌̔̋̋͗̈́̔̐͆̈́̓̾̄̀́̏́͒̆̌͒̈́̈́̾̏̀͜͝g̸̖͂͋̊͗̈́̓̆̈̋̒͐̕o̶̧̢͓̲̗̠̘͕̦̤̹̗͉̰͔̯͓̭̹̻͔͇̯̜̙̍̂̃̃̀̓͌̒͊̊̋̒̿̿̌͐̄͗̾̕͝T̶̛̳̜̰͍̹̻̫̠̱̼̼̙̆̑̾̾͛́́̿͋͌̎̀̀̽̆͌̽̂̈̇̅̇̃́̿͗̾͒̎͊̑̾͝͠ȩ̸̢̨̛̛̛̭͔͎͇̫͎͈̲̻̙͕͎̣͈̩̺̗͖͙͇͌͐̒̎͐̓́̉́͐̓̐͌̅̊͋͑̈́͗͑̏̕͜͜͝ͅx̸̧̧̛̖̣̥̘͎͎̳̭̙̦̝͖̝̮̱̹̯̺̙̩̯̮͖̻̰͓̰̩͇̥̑͌̊̐̉̏͆̓̑̎̊̓͒̂̄̆͆̀̊̄̈̽͐͛̏͊̓̌͑́̎̈́̍̈́̊͗̉̋͆̿̊͘͜͜͝͝ͅͅͅt̵̡̨̜̘͎̦͚̠̗̺͉̼̠̲̠͙̺̹̗̲̏̈́̂̚͜͜͝ͅ"
# ------------------------
}
proc test_farmer {} {
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
@ -620,17 +662,29 @@ tcl::namespace::eval punk::char {
puts stdout "farmer2 with no joiner codes: \\U0001f9d1\\U001f33e : $farmer2"
package require punk::console
puts stdout \n
puts stdout "#2--5---9---C---"
puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1
puts -nonewline "${farmer1}";set cursorposn [punk::console::get_cursor_pos]
puts stdout \n
puts stdout "cursor position immediately after outputing farmer1 (expecting 1 glyph 2 wide) : $cursorposn"
puts -nonewline "${farmer1}";set cursorposn [punk::console::get_cursor_pos_list]
puts stdout "\ncursor position immediately after outputing farmer1 (expecting 1 glyph 2 wide) : cursor at col [lindex $cursorposn 1]"
if {[lindex $cursorposn 1] eq "3"} {
puts stdout "[a+ green]OK[a]"
} else {
puts stdout "[a+ red]ERR - expected cursor position to be 3 after emitting farmer1[a]"
}
puts stdout "----------------"
puts stdout "#2--5---9---C---"
puts -nonewline "${farmer2}";set cursorposn [punk::console::get_cursor_pos]
puts stdout \n
puts stdout "cursor position immediately after outputing farmer2 (expecting 2 glyphs 4 wide in total): $cursorposn"
puts -nonewline "${farmer2}";set cursorposn [punk::console::get_cursor_pos_list]
puts stdout "\ncursor position immediately after outputing farmer2 (expecting 2 glyphs 4 wide in total): cursor at col [lindex $cursorposn 1]"
if {[lindex $cursorposn 1] eq "5"} {
puts stdout "[a+ green]OK[a]"
} else {
puts stdout "[a+ red]ERR - expected cursor position to be 5 after emitting farmer2[a]"
}
puts stdout "----------------"
return [list $farmer1 $farmer2]
puts "returning farmer1 - should be single glyph"
return $farmer1
}
#G0 Sets Sequence G1 Sets Sequence Meaning
@ -1916,6 +1970,172 @@ tcl::namespace::eval punk::char {
# - tab/vtab?
# - compare with wcswidth returning -1 for entire string containing such in python,perl
proc wcswidth {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?)
#Tcl initial evaluation stack size is 2000 (? review)
#REVIEW - when we cater for grapheme clusters - we can't just split the string at arbitrary points like this!!
set chunksize 2000
set chunks_required [expr {int(ceil([tcl::string::length $string] / double($chunksize)))}]
set width 0
set startidx 0
set endidx [expr {$startidx + $chunksize -1}]
for {set i 0} {$i < $chunks_required} {incr i} {
set chunk [tcl::string::range $string $startidx $endidx]
set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]]
foreach c $codes {
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
incr startidx $chunksize
incr endidx $chunksize
}
return $width
}
# ------------------------------------------------------------------------------------------------------
#test
# ------------------------------------------------------------------------------------------------------
proc grapheme_split_tk {string} {
if {![regexp "\[\uFF-\U10FFFF\]" $string]} {
#only ascii - no joiners or unicode
return [split $string {}]
}
package require tk
set i 0
set graphemes [list]
while {$i < [tcl::string::length $string]} {
set aftercluster [tk::endOfCluster $string $i]
lappend graphemes [string range $string $i $aftercluster-1]
set i $aftercluster
}
return $graphemes
}
proc wcswidth_clustered {string} {
package require tk
set width 0
set i 0
if {![regexp "\[\uFF-\U10FFFF\]" $string]} {
return [punk::char::wcswidth_unclustered $string] ;#still use our wcswidth to account for non-printable ascii
}
while {$i < [tcl::string::length $string]} {
set aftercluster [tk::endOfCluster $string $i]
set g [string range $string $i $aftercluster-1]
if {$aftercluster > ($i + 1)} {
#review - proper way to determine screen width (columns occupied) of a cluster??
#according to this:
#https://lib.rs/crates/unicode-display-width
#for each grapheme - if any of the code points in the cluster have an east asian width of 2,
#The entire grapheme width is 2 regardless of how many code points constitute the grapheme
set gw 1
foreach ch [split $g ""] {
if {[punk::char::wcswidth_single $ch] == 2} {
set gw 2
break
}
}
incr width $gw
#if {[string first \u200d $g] >=0} {
# incr width 2
#} else {
# #other joiners???
# incr width [wcswidth_unclustered $g]
#}
} else {
incr width [wcswidth_unclustered $g]
}
set i $aftercluster
}
return $width
}
proc wcswidth_single {char} {
scan $c %c dec
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
return 1
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
return [textutil::wcswidth_char $c]
#may return -1 - REVIEW
}
return 0
}
proc wcswidth_unclustered1 {string} {
set width 0
foreach c [split $string {}] {
scan $c %c dec
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
return $width
}
#todo - consider disallowing/erroring out when \r \n in string?
# - tab/vtab?
# - compare with wcswidth returning -1 for entire string containing such in python,perl
proc wcswidth_unclustered {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?)
#Tcl initial evaluation stack size is 2000 (? review)
#we can only split the string at arbitrary points like this because we are specifically dealing with input that has no clusters!.
set chunksize 2000
set chunks_required [expr {int(ceil([tcl::string::length $string] / double($chunksize)))}]
set width 0
set startidx 0
set endidx [expr {$startidx + $chunksize -1}]
for {set i 0} {$i < $chunks_required} {incr i} {
set chunk [tcl::string::range $string $startidx $endidx]
set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]]
foreach c $codes {
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
incr startidx $chunksize
incr endidx $chunksize
}
return $width
}
# ------------------------------------------------------------------------------------------------------
proc wcswidth0 {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+
#TODO
@ -1943,20 +2163,6 @@ tcl::namespace::eval punk::char {
}
return $width
}
#faster than textutil::wcswidth (at least for string up to a few K in length)
proc wcswidth1 {string} {
set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]]
set width 0
foreach c $codes {
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
return $width
}
proc wcswidth2 {string} {
set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]]
set widths [lmap c $codes {textutil::wcswidth_char $c}]

1
src/modules/punk/console-999999.0a1.0.tm

@ -875,6 +875,7 @@ namespace eval punk::console {
}
}
punk::args::set_alias punk::console::code_a+ punk::ansi::a+
proc code_a+ {args} {
variable ansi_wanted
if {$ansi_wanted <= 0} {

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

@ -962,21 +962,6 @@ namespace eval punk::lib {
namespace import ::punk::args::lib::tstr
#get info about punk nestindex key ie type: list,dict,undetermined
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
}
proc invoke command {
@ -1127,17 +1112,35 @@ namespace eval punk::lib {
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
-keysorttype -default "none" -choices {none dictionary ascii integer real}
-keysortdirection -default increasing -choices {increasing decreasing}
-debug -default 0 -type boolean -help\
"When enabled, produces some rudimentary debug output on stderr"
*values -min 1 -max -1
dictvalue -type list -help "dict or list value"
patterns -default "*" -type string -multiple 1 -help "key or key glob pattern"
}] $args]
#for punk::lib - we want to reduce pkg dependencies.
# - so we won't even use the tcllib debug pkg here
set opt_debug [dict get $argd opts -debug]
if {$opt_debug} {
if {[info body debug::showdict] eq ""} {
proc ::punk::lib::debug::showdict {args} {
catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"}
}
}
} else {
if {[info body debug::showdict] ne ""} {
proc ::punk::lib::debug::showdict {args} {}
}
}
set opt_sep [dict get $argd opts -separator]
set opt_mismatch_sep [dict get $argd opts -separator_mismatch]
set opt_keysorttype [dict get $argd opts -keysorttype]
set opt_keysortdirection [dict get $argd opts -keysortdirection]
set opt_trimright [dict get $argd opts -trimright]
set opt_keytemplates [dict get $argd opts -keytemplates]
puts stderr "---> $opt_keytemplates <---"
debug::showdict "keytemplates ---> $opt_keytemplates <---"
set opt_ansibase_keys [dict get $argd opts -ansibase_keys]
set opt_ansibase_values [dict get $argd opts -ansibase_values]
set opt_return [dict get $argd opts -return]
@ -4112,10 +4115,31 @@ tcl::namespace::eval punk::lib::system {
return $incomplete
}
#get info about punk nestindex key ie type: list,dict,undetermined
# pdict devel
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
#???
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
}
tcl::namespace::eval punk::lib::debug {
proc showdict {args} {}
}
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace

5
src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm

@ -31,8 +31,9 @@ namespace eval punk::mix::commandset::loadedlib {
*proc -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter"
-return -type string -default table -choices {table tableobject list lines}
-present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\
"(unimplemented) Display only those that are 0:absent 1:present 2:both"
-highlight -type boolean -default 1 -help "Highlight which version is present with ansi underline and colour"
"(unimplemented) Display only those that are 0:absent 1:present 2:either"
-highlight -type boolean -default 1 -help\
"Highlight which version is present with ansi underline and colour"
-refresh -default 0 -type boolean -help "Re-scan the tm and library folders"
searchstrings -default * -multiple 1 -help\
"Names to search for, may contain glob chars (* ?) e.g *lib*

22
src/modules/punk/ns-999999.0a1.0.tm

@ -1896,6 +1896,10 @@ tcl::namespace::eval punk::ns {
*id punk::ns::arginfo
*proc -name punk::ns::arginfo -help\
"Show usage info for a command"
-return -type string -default table -choices {string table tableobject}
-- -type none -help\
"End of options marker
Use this if the command to view begins with a -"
*values -min 1
commandpath -help\
"command (may be alias or ensemble)"
@ -2050,7 +2054,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$origin new"]
return [punk::args::usage {*}$opts "$origin new"]
}
create {
set constructorinfo [info class constructor $origin]
@ -2079,7 +2083,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$origin create"]
return [punk::args::usage {*}$opts "$origin create"]
}
destroy {
#review - generally no doc
@ -2092,7 +2096,7 @@ tcl::namespace::eval punk::ns {
*values -min 0 -max 0
}]
punk::args::definition $argspec
return [punk::args::usage "$origin destroy"]
return [punk::args::usage {*}$opts "$origin destroy"]
}
default {
#use info object call <obj> <method> to resolve callchain
@ -2112,7 +2116,7 @@ tcl::namespace::eval punk::ns {
set id "[string trimleft $origin :] $c1" ;# "<object> <method>"
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set def [::info object definition $origin $c1]
@ -2120,7 +2124,7 @@ tcl::namespace::eval punk::ns {
set id "[string trimleft $location :] $c1" ;# "<class> <method>"
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set def [::info class definition $location $c1]
@ -2162,7 +2166,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$location $c1"]
return [punk::args::usage {*}$opts "$location $c1"]
} else {
return "unable to resolve $origin method $c1"
}
@ -2216,7 +2220,7 @@ tcl::namespace::eval punk::ns {
}]
append argspec \n $vline
punk::args::definition $argspec
return [punk::args::usage $origin]
return [punk::args::usage {*}$opts $origin]
}
privateObject {
return "Command is a privateObject - no info currently available"
@ -2327,7 +2331,7 @@ tcl::namespace::eval punk::ns {
}]
append argspec \n $vline
punk::args::definition $argspec
return [punk::args::usage $origin]
return [punk::args::usage {*}$opts $origin]
}
#check for tepam help
@ -2363,7 +2367,7 @@ tcl::namespace::eval punk::ns {
set id [string trimleft $origin :]
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set origin_ns [nsprefix $origin]

17
src/modules/punk/repl-0.1.tm

@ -2584,7 +2584,8 @@ namespace eval repl {
set codethread_cond [thread::cond create] ;#repl::codethread_cond held by parent(repl) vs punk::repl::codethread::replthread_cond held by child(codethread)
set codethread_mutex [thread::mutex create]
thread::send $codethread [string map [list %args% [list $opts]\
set init_script [string map [list %args% [list $opts]\
%argv0% [list $::argv0]\
%argv% [list $::argv]\
%argc% [list $::argc]\
@ -3097,8 +3098,20 @@ namespace eval repl {
#puts stderr "returning threadid"
#puts stderr [thread::id]
return [thread::id]
thread::id
}]
#thread::send $codethread $init_script
if {![catch {
thread::send $codethread $init_script result ;#use a result var when wrapping in a catch - without it we can get a return code of 2 (TCL_RETURN)
} errMsg]} {
return $result
} else {
puts stderr "repl::init Failed during thread::send"
puts stderr "$::errorInfo"
thread::release $codethread
error $errMsg
}
}
#init - don't auto init - require init with possible options e.g -safe
}

2
src/modules/punk/repl/codethread-999999.0a1.0.tm

@ -190,7 +190,7 @@ tcl::namespace::eval punk::repl::codethread {
if {[llength $::codeinterp::run_command_cache] > 2000} {
set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache]
}
if {[string first ":::" $::punk::ns::ns_current]} {
if {[string first ":::" $::punk::ns::ns_current] >= 0} {
#support for browsing 'odd' (inadvisable) namespaces
#don't use 'namespace exists' - will conflate ::test::x with ::test:::x
#if {$::punk::ns::ns_current in [namespace children [punk::ns::nsprefix $::punk::ns::ns_current]} {

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

@ -299,6 +299,9 @@ tcl::namespace::eval textblock {
#It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp.
#e.g $t configure -framemap_body [table_edge_map " "]
# -- --- --- --- ---
#unused?
proc table_edge_map {char} {
variable table_edge_parts
set map [list]
@ -335,6 +338,7 @@ tcl::namespace::eval textblock {
}
return $map
}
# -- --- --- --- ---
if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} {
#*** !doctools
@ -374,6 +378,7 @@ tcl::namespace::eval textblock {
variable o_columndefs
variable o_columndata
variable o_columnstates
variable o_headerdefs
variable o_headerstates
variable o_rowdefs
@ -432,6 +437,7 @@ tcl::namespace::eval textblock {
set o_columndefs [tcl::dict::create]
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_headerdefs [tcl::dict::create] ;#by header-row
set o_headerstates [tcl::dict::create]
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
@ -439,12 +445,14 @@ tcl::namespace::eval textblock {
set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices.
set o_calculated_column_widths [list]
set o_column_width_algorithm "span"
set header_defaults [tcl::dict::create\
set o_opts_header_defaults [tcl::dict::create\
-colspans {}\
-values {}\
-ansibase {}\
-ansireset "\x1b\[m"\
-minheight 1\
-maxheight ""\
]
set o_opts_header_defaults $header_defaults
}
method width_algorithm {{alg ""}} {
@ -1107,10 +1115,18 @@ tcl::namespace::eval textblock {
}
}
}
#args checked - ok to update headerstates and columndefs and columnstates
#args checked - ok to update headerstates, headerdefs and columndefs and columnstates
tcl::dict::set o_columndefs $cidx $checked_opts
set o_headerstates $hstates
dict for {hidx hstate} $hstates {
#configure_header
if {![dict exists $o_headerdefs $hidx]} {
#remove calculated members -values -colspans
set hdefaults [dict remove $o_opts_header_defaults -values -colspans]
dict set o_headerdefs $hidx $hdefaults
}
}
tcl::dict::set o_columnstates $cidx $colstate
if {$args_got_headers} {
@ -1267,11 +1283,10 @@ tcl::namespace::eval textblock {
return $hcolspans
}
#should be configure_headerrow ?
method configure_header {index_expression args} {
#*** !doctools
#[call class::table [method configure_header]]
#[para] - undocumented
#[para] - configure header row-wise
#the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs.
#It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis
@ -1279,7 +1294,7 @@ tcl::namespace::eval textblock {
set num_headers [my header_count_calc]
set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression]
if {$hidx eq ""} {
error "textblock::table::configure_header - no row defined at index '$hidx'."
error "textblock::table::configure_header - no header row defined at index '$index_expression'."
}
if {$hidx > $num_headers -1} {
#assert - shouldn't happen
@ -1298,6 +1313,14 @@ tcl::namespace::eval textblock {
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
}
tcl::dict::set result -values $header_row_items
#review - ensure always a headerdef record for each header?
if {[tcl::dict::exists $o_headerdefs $hidx]} {
set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]]
} else {
#warn for now
puts stderr "no headerdef record for header $hidx"
}
return $result
}
if {[llength $args] == 1} {
@ -1328,7 +1351,8 @@ tcl::namespace::eval textblock {
set colspans_by_header [my header_colspans]
set result [tcl::dict::create]
set val [tcl::dict::get $colspans_by_header $hidx]
set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"]
#ansireset not required
set returndict [tcl::dict::create option $k value $val]
}
-ansibase {
set val ???
@ -1369,8 +1393,7 @@ tcl::namespace::eval textblock {
lappend header_ansibase_items $code
}
}
set header_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items]
error "sorry - -ansibase not yet implemented for header rows"
set header_ansibase [punk::ansi::codetype::sgr_merge_singles $header_ansibase_items]
lappend checked_opts $k $header_ansibase
}
-ansireset {
@ -1472,6 +1495,10 @@ tcl::namespace::eval textblock {
#safe jumptable test
#dict for {k v} $checked_opts {}
#foreach {k v} $checked_opts {}
# headerdefs excludes -values and -colspans
set update_hdefs [tcl::dict::get $o_headerdefs $hidx]
tcl::dict::for {k v} $checked_opts {
switch -- $k {
-values {
@ -1538,8 +1565,28 @@ tcl::namespace::eval textblock {
incr c
}
}
default {
dict set update_hdefs $k $v
}
}
}
set opt_minh [tcl::dict::get $update_hdefs -minheight]
set opt_maxh [tcl::dict::get $update_hdefs -maxheight]
#todo - allow zero values to hide/collapse
# - see also configure_row
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
}
#set o_headerstate $hidx -minheight? -maxheight? ???
tcl::dict::set o_headerdefs $hidx $update_hdefs
}
method add_row {valuelist args} {
@ -2050,7 +2097,8 @@ tcl::namespace::eval textblock {
foreach header $header_list {
set headerspans [tcl::dict::get $all_colspans $hrow]
set this_span [lindex $headerspans $cidx]
set hval $ansibase_header$header ;#no reset
#set hval $ansibase_header$header ;#no reset
set hval $header
set rowh [my header_height $hrow]
if {$hrow == 0} {
@ -2317,7 +2365,7 @@ tcl::namespace::eval textblock {
set h_lines [lrepeat $rowh $bline]
set hcell_blank [::join $h_lines \n]
# -usecache 1 ok
#frame borders will never display - so use the simplest frametype and don't apply any ansi
#frame borders will never display - so use the simplest frametype and don't apply any ansi
#puts "===>zerospan hlims: $hlims"
set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\
-boxlimits $hlims -boxmap $framesub_map $hcell_blank\
@ -2589,8 +2637,8 @@ tcl::namespace::eval textblock {
}
}
set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body]
set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header]
#set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body]
#set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header]
#set header_underlay $ansibase_header$cell_line_blank
@ -2613,7 +2661,35 @@ tcl::namespace::eval textblock {
set showing_vseps [my Showing_vseps]
for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} {
set hdr [lindex $headerlist $hrow]
set header_maxdataheight [my header_height $hrow] ;#from cached headerstates
#jjj
set header_maxdataheight [tcl::dict::get $o_headerstates $hrow maxheightseen]
#set header_maxdataheight [my header_height $hrow] ;#from cached headerstates
set headerdefminh [tcl::dict::get $o_headerdefs $hrow -minheight]
set headerdefmaxh [tcl::dict::get $o_headerdefs $hrow -maxheight]
if {"$headerdefminh$headerdefmaxh" ne "" && $headerdefminh eq $headerdefmaxh} {
set headerh $headerdefminh ;#exact height defined for the row
} else {
if {$headerdefminh eq ""} {
if {$headerdefmaxh eq ""} {
#both defs empty
set headerh $header_maxdataheight
} else {
set headerh [expr {min(1,$headerdefmaxh,$header_maxdataheight)}]
}
} else {
if {$headerdefmaxh eq ""} {
set headerh [expr {max($headerdefminh,$header_maxdataheight)}]
} else {
if {$header_maxdataheight < $headerdefminh} {
set headerh $headerdefminh
} else {
set headerh [expr {max($headerdefminh,$header_maxdataheight)}]
}
}
}
}
set headerrow_colspans [tcl::dict::get $all_colspans $hrow]
set this_span [lindex $headerrow_colspans $cidx]
@ -2654,8 +2730,7 @@ tcl::namespace::eval textblock {
set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight]
set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight]
if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} {
#an exact height is defined for the row
set rowh $rowdefminh
set rowh $rowdefminh ;#an exact height is defined for the row
} else {
if {$rowdefminh eq ""} {
if {$rowdefmaxh eq ""} {
@ -2814,6 +2889,7 @@ tcl::namespace::eval textblock {
$t destroy
}
puts stdout "columnstates: $o_columnstates"
puts stdout "headerdefs: $o_headerdefs"
puts stdout "headerstates: $o_headerstates"
tcl::dict::for {k coldef} $o_columndefs {
if {[tcl::dict::exists $o_columndata $k]} {
@ -4205,6 +4281,68 @@ tcl::namespace::eval textblock {
return $t
}
proc bookend_lines {block start {end "\x1b\[m"}} {
set out ""
foreach ln [split $block \n] {
append out $start $ln $end \n
}
return [string range $out 0 end-1]
}
proc ansibase_lines {block {newprefix ""}} {
set base ""
set out ""
if {$newprefix eq ""} {
foreach ln [split $block \n] {
set parts [punk::ansi::ta::split_codes $ln]
if {[lindex $parts 0] eq ""} {
if {[lindex $parts 1] ne "" && ![punk::ansi::codetype::is_sgr_reset [lindex $parts 1]]} {
set base [lindex $parts 1]
append out $base
} else {
append out $base
}
} else {
#leading plaintext - maintain our base
append out $base [lindex $parts 0] [lindex $parts 1]
}
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]
}
incr code_idx 2
}
append out {*}[lrange $parts 2 end] \n
}
return [string range $out 0 end-1]
} else {
set base $newprefix
foreach ln [split $block \n] {
set parts [punk::ansi::ta::split_codes $ln]
set code_idx 1
set offset 0
foreach {pt code} $parts {
if {$code_idx == 1} {
#first pt & code
if {$pt ne ""} {
#leading plaintext
set parts [linsert $parts 0 $base]
incr offset
}
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts [expr {$code_idx+1+$offset}] $base]
incr offset
}
incr code_idx 2
}
append out {*}$parts \n
}
return [string range $out 0 end-1]
}
}
set FRAMETYPES [textblock::frametypes]
punk::args::definition [punk::lib::tstr -return string {
*id textblock::list_as_table
@ -4606,12 +4744,22 @@ tcl::namespace::eval textblock {
return [punk::char::ansifreestring_width $tl]
}
#uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function.
proc string_length_line_max textblock {
tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
proc string_length_line_max {textblock} {
#tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
set max 0
foreach ln [split $textblock \n] {
if {[tcl::string::length $ln] > $max} {set max [tcl::string::length $ln]}
}
return $max
}
#*slightly* slower
#proc string_length_line_max {textblock} {
# tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
#}
proc string_length_line_min textblock {
tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
}
proc height {textblock} {
#This is the height as it will/would-be rendered - not the number of input lines purely in terms of le
#empty string still has height 1 (at least for left-right/right-left languages)
@ -4652,6 +4800,45 @@ tcl::namespace::eval textblock {
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size2 {textblock} {
if {$textblock eq ""} {
return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack
if {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
set lines [split $textblock \n]
set num_le [expr {[llength $lines]-1}]
#set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]]
set width 0
foreach ln $lines {
set w [::punk::char::ansifreestring_width $ln]
if {$w > $width} {
set width $w
}
}
} else {
set num_le 0
set width [punk::char::ansifreestring_width $textblock]
}
#set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list
#our concept of block-height is likely to be different to other line-counting mechanisms
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size_as_opts {textblock} {
set sz [size $textblock]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]

44
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm

@ -729,7 +729,7 @@ tcl::namespace::eval overtype {
-width [tcl::dict::get $vtstate renderwidth]\
-insert_mode [tcl::dict::get $vtstate insert_mode]\
-autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\
-expand_right [tcl::dict::get $opts -opt_expand_right]\
-expand_right [tcl::dict::get $opts -expand_right]\
""\
$overflow_right\
]
@ -1366,7 +1366,7 @@ tcl::namespace::eval overtype {
if {$overflowlength > 0} {
#overlay line wider or equal
#review - we still expand_right for centred for now.. possibly should expand_both with ellipsis each end?
#review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end?
set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
@ -1771,7 +1771,7 @@ tcl::namespace::eval overtype {
#-returnextra enables returning of overflow and length
#review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation?
#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements
#(could render it by faking it with sixels and a lot of work - find/make a sixel font (converter?) and ensure it's exactly 2 cols per char?
#(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char?
# This would probably be impractical to support for different fonts)
#todo - review transparency issues with single/double width characters
#bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer?
@ -2815,6 +2815,7 @@ tcl::namespace::eval overtype {
\x1b\[< 1006\
\x1b\[ 7CSI\
\x1bP 7DCS\
\x90 8DCS\
\x9b 8CSI\
\x1b\] 7OSC\
\x9d 8OSC\
@ -2836,6 +2837,10 @@ tcl::namespace::eval overtype {
#Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]]
}
8DCS {
#8-bit Device Control String
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
7ESC {
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
@ -3265,6 +3270,17 @@ tcl::namespace::eval overtype {
puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
T {
#CSI Pn T - SD Pan Up (empty lines introduced at top)
#CSI Pn+T - kitty extension (lines at top come from scrollback buffer)
#Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display
if {$param eq "" || $param eq "0"} {set param 1}
if {[string index $param end] eq "+"} {
puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
} else {
puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
X {
puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param"
#ECH - erase character
@ -3862,9 +3878,14 @@ tcl::namespace::eval overtype {
}
}
7DCS {
7DCS - 8DCS {
puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
#
#ST (string terminator) \x9c or \x1b\\
if {[tcl::string::index $codenorm end] eq "\x9c"} {
set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c
} else {
set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\
}
}
7OSC - 8OSC {
@ -3934,6 +3955,12 @@ tcl::namespace::eval overtype {
#tektronix cursor color
puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
99 {
#kitty desktop notifications
#https://sw.kovidgoyal.net/kitty/desktop-notifications/
#<OSC> 99 ; metadata ; payload <terminator>
puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
104 {
#reset colour palette
#we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt
@ -3942,6 +3969,13 @@ tcl::namespace::eval overtype {
set instruction [list reset_colour_palette]
break
}
1337 {
#iterm2 graphics and file transfer
puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]"
}
5113 {
puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]"
}
default {
puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}

164
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm

@ -101,12 +101,15 @@ set punk_testd2 [dict create \
] \
]
#impolitely cooperative withe punk repl - todo - tone it down.
#impolitely cooperative with punk repl - todo - tone it down.
#namespace eval ::punk::repl::codethread {
# variable running 0
#}
package require punk::lib
package require punk::lib ;# subdependency punk::args
package require punk::ansi
if {![llength [info commands ::ansistring]]} {
namespace import punk::ansi::ansistring
}
#require aliascore after punk::lib & punk::ansi are loaded
package require punk::aliascore ;#mostly punk::lib aliases
punk::aliascore::init
@ -114,9 +117,6 @@ punk::aliascore::init
package require punk::repl::codethread
package require punk::config
#package require textblock
if {![llength [info commands ::ansistring]]} {
namespace import punk::ansi::ansistring
}
package require punk::console
package require punk::ns
package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems
@ -862,6 +862,8 @@ namespace eval punk {
}
}
#? {
#review - compare to %# ?????
#seems to be unimplemented ?
set assigned [string length $leveldata]
set already_assigned 1
}
@ -7149,12 +7151,93 @@ namespace eval punk {
dict filter $result value {?*}
}
punk::args::definition {
*id punk::inspect
*proc -name punk::inspect -help\
"Function to display values - used pimarily in a punk pipeline.
The raw value arguments (not options) are always returned to pass
forward in the pipeline.
(pipeline data inserted at end of each |...> segment is passed as single item unless
inserted with an expanding insertion specifier such as .=>* )
e.g1:
.= list a b c |v1,/1-end,/0>\\
.=>* inspect -label i1 -- |>\\
.=v1> inspect -label i2 -- |>\\
string toupper
(3) i1: {a b c} {b c} a
(1) i2: a b c
- A B C
"
-label -type string -default "" -help\
"An optional label to help distinguish output when multiple
inspect statements are in a pipeline. This appears after the
bracketed count indicating number of values supplied.
e.g (2) MYLABEL: val1 val2
The label can include ANSI codes.
e.g
inspect -label [a+ red]mylabel -- val1 val2 val3
"
-limit -type int -default 20 -help\
"When multiple values are passed to inspect - limit the number
of elements displayed in -channel output.
When truncation has occured an elipsis indication (...) will be appended.
e.g
.= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+
(11) 20 23 26 29...
- 385
For no limit - use -limit -1
"
-channel -type string -default stderr -help\
"An existing open channel to write to. If value is any of nul, null, /dev/nul
the channel output is disabled. This effectively disables inspect as the args
are simply passed through in the return to continue the pipeline.
"
-showcount -type boolean -default 1 -help\
"Display a leading indicator in brackets showing the number of arg values present."
-ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels {
0 "Strip ANSI codes from display
of values. The disply output will
still be colourised if -ansibase has
not been set to empty string or
[a+ normal]. The stderr or stdout
channels may also have an ansi colour.
(see 'colour off' or punk::config)"
1 "Leave value as is"
2 "Display the ANSI codes and
other control characters inline
with replacement indicators.
e.g esc, newline, space, tab"
VIEW "Alias for 2"
3 "Display as per 2 but with
colourised ANSI replacement codes."
VIEWCODES "Alias for 3"
4 "Display ANSI and control
chars in default colour, but
apply the contained ansi to
the text portions so they display
as they would for -ansi 1"
VIEWSTYLE "Alias for 4"
}
-ansibase -type ansistring -default {${[a+ brightgreen]}} -help\
"Base ansi code(s) that will apply to output written to the chosen -channel.
If there are ansi resets in the displayed values - output will revert to this base.
Does not affect return value."
-- -type none -help\
"End of options marker.
It is advisable to use this, as data in a pipeline may often being with -"
*values -min 0 -max -1
arg -type string -optional 1 -multiple 1 -help\
"value to display"
}
#pipeline inspect
#e.g
#= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data}
proc inspect {args} {
set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1]
set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1 -ansibase [a+ brightgreen]]
set flags [list]
set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect --
if {$endoptsposn >= 0} {
@ -7177,24 +7260,28 @@ namespace eval punk {
}
foreach {k v} $flags {
if {$k ni [dict keys $defaults]} {
error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --"
#error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --"
punk::args::get_by_id punk::inspect $args
}
}
set opts [dict merge $defaults $flags]
# -- --- --- --- ---
set label [dict get $opts -label]
set channel [dict get $opts -channel]
set showcount [dict get $opts -showcount]
set label [dict get $opts -label]
set channel [dict get $opts -channel]
set showcount [dict get $opts -showcount]
if {[string length $label]} {
set label "${label}: "
}
set limit [dict get $opts -limit]
set opt_ansi [dict get $opts -ansi]
set opt_ansiraw [dict get $opts -ansi]
set opt_ansi [tcl::prefix::match -error "" [list 0 1 2 3 4 view viewcodes viewstyle] [string tolower $opt_ansiraw]]
switch -- [string tolower $opt_ansi] {
0 - 1 - 2 {}
view {set opt_ansi 2}
0 - 1 - 2 - 3 - 4 {}
view {set opt_ansi 2}
viewcodes {set opt_ansi 3}
viewstyle {set opt_ansi 4}
default {
error "inspect -ansi 0|1|2|view - received -ansi $opt_ansi"
error "inspect -ansi 0|1|2|view|3|viewcodes|4|viewstyle - received -ansi $opt_ansiraw"
}
}
# -- --- --- --- ---
@ -7248,15 +7335,50 @@ namespace eval punk {
} else {
set displaycount ""
}
if {$opt_ansi == 0} {
set displayval [punk::ansi::ansistrip $displayval]
} elseif {$opt_ansi == 2} {
set displayval [ansistring VIEW $displayval]
set ansibase [dict get $opts -ansibase]
if {$ansibase ne ""} {
#-ansibase default is hardcoded into punk::args definition
#run a test using any ansi code to see if colour is still enabled
if {[a+ red] eq ""} {
set ansibase "" ;#colour seems to be disabled
}
}
switch -- $opt_ansi {
0 {
set displayval $ansibase[punk::ansi::ansistrip $displayval]
}
1 {
#val may have ansi - including resets. Pass through ansibase_lines to
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
2 {
set displayval $ansibase[ansistring VIEW $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
3 {
set displayval $ansibase[ansistring VIEWCODE $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
4 {
set displayval $ansibase[ansistring VIEWSTYLE $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
}
if {![string length $more]} {
puts $channel "$displaycount$label[a green bold]$displayval[a]"
puts $channel "$displaycount$label$displayval[a]"
} else {
puts $channel "$displaycount$label[a green bold]$displayval[a yellow bold]$more[a]"
puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]"
}
return $val
}

19
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm

@ -167,6 +167,7 @@ tcl::namespace::eval punk::ansi::class {
}
default {
puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x"
punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args
}
}
}
@ -2415,6 +2416,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
*id punk::ansi::a+
*proc -name "punk::ansi::a+" -help\
"Returns an ANSI sgr escape sequence based on the list of supplied codes.
Unlike punk::ansi::a - it is not prefixed with an ANSI reset.
"
*values -min 0 -max -1
} [string map [list <choices> [dict keys $SGR_map]] {
@ -2432,10 +2434,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
The acceptable values for <termcolour> and <webcolour> can be queried using
punk::ansi::a? term
and
punk::ansi::a? web"
punk::ansi::a? web
Example to set foreground red and background cyan followed by a reset:
set str \"[a+ red Cyan]sample text[a]\"
"
}]]
proc a+ {args} {
#*** !doctools
#[call [fun a+] [opt {ansicode...}]]
@ -7065,13 +7069,12 @@ tcl::namespace::eval punk::ansi::ansistring {
}
}
#inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi
#todo - document
interp alias {} ansistring {} ::punk::ansi::ansistring
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}]
}
tcl::namespace::eval punk::ansi::control {
proc APC {args} {
return \x1b_[join $args {;}]\x1b\\
@ -7393,6 +7396,10 @@ tcl::namespace::eval punk::ansi::internal {
}
}
#inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi
#todo - document
interp alias {} ansistring {} ::punk::ansi::ansistring
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set NAMESPACES [list]

87
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm

@ -353,7 +353,7 @@ tcl::namespace::eval punk::args {
}
set optionspecs [join $normargs \n]
if {[string first \$\{ $optionspecs] > 0} {
set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 $optionspecs]]
set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]]
}
} else {
if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} {
@ -1262,30 +1262,43 @@ tcl::namespace::eval punk::args {
if {$arg_error_isrunning} {
error "arg_error already running - error in arg_error?\n triggering errmsg: $msg"
}
set arg_error_isrunning 1
if {[llength $args] %2 != 0} {
error "error in arg_error processing - expected opt/val pairs after msg and spec_dict"
}
set arg_error_isrunning 1
set badarg ""
set returntype error
set returntype table ;#table as string
set as_error 1 ;#usual case is to raise an error
dict for {k v} $args {
switch -- $k {
-badarg {
set badarg $v
}
-aserror {
if {![string is boolean -strict $v]} {
set arg_error_isrunning 0
error "arg_error invalid value for option -aserror. Received '$v' expected a boolean"
}
set as_error $v
}
-return {
if {$v ni {error string}} {
error "arg_error invalid value for option -return. Received '$v' expected one of: error string"
if {$v ni {string table tableobject}} {
set arg_error_isrunning 0
error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject"
}
set returntype $v
}
default {
set arg_error_isrunning 0
error "arg_error invalid option $k. Known_options: -badarg -return"
}
}
}
set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist.
#REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error
#e.g list_as_table
@ -1300,12 +1313,20 @@ tcl::namespace::eval punk::args {
#couldn't load textblock package
#just return the original errmsg without formatting
}
set use_table 0
if {$has_textblock && $returntype in {table tableobject}} {
set use_table 1
}
set errlines [list] ;#for non-textblock output
if {[catch {
if {$has_textblock} {
if {$use_table} {
append errmsg \n
} else {
append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n
if {($returntype in {table tableobject}) && !$has_textblock} {
append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n
} else {
append errmsg \n
}
}
set procname [Dict_getdef $spec_dict proc_info -name ""]
set prochelp [Dict_getdef $spec_dict proc_info -help ""]
@ -1333,7 +1354,7 @@ tcl::namespace::eval punk::args {
} else {
set docurl_display ""
}
if {$has_textblock} {
if {$use_table} {
set t [textblock::class::table new [a+ brightyellow]Usage[a]]
$t add_column -headers $blank_header_col -minwidth 3
$t add_column -headers $blank_header_col
@ -1343,7 +1364,7 @@ tcl::namespace::eval punk::args {
}
set h 0
if {$procname ne ""} {
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display]
} else {
lappend errlines "PROC/METHOD: $procname_display"
@ -1351,7 +1372,7 @@ tcl::namespace::eval punk::args {
incr h
}
if {$prochelp ne ""} {
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list Description: $prochelp_display]
} else {
lappend errlines "Description: $prochelp_display"
@ -1362,14 +1383,14 @@ tcl::namespace::eval punk::args {
if {![catch {package require punk::ansi}]} {
set docurl [punk::ansi::hyperlink $docurl]
}
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list $docname $docurl_display]
} else {
lappend errlines "$docname $docurl_display"
}
incr h
}
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -values {Arg Type Default Multi Help}
} else {
lappend errlines " --ARGUMENTS-- "
@ -1519,7 +1540,7 @@ tcl::namespace::eval punk::args {
set numcols [llength $formattedchoices]
}
if {$numcols > 0} {
if {$has_textblock} {
if {$use_table} {
#risk of recursing
set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices]
append help \n[textblock::join -- " " $choicetable]
@ -1565,7 +1586,7 @@ tcl::namespace::eval punk::args {
append typeshow \n "-range [dict get $arginfo -range]"
}
if {$has_textblock} {
if {$use_table} {
$t add_row [list $argshow $typeshow $default $multiple $help]
if {$arg eq $badarg} {
$t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG
@ -1577,11 +1598,14 @@ tcl::namespace::eval punk::args {
}
}
if {$has_textblock} {
if {$use_table} {
$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow]
$t configure -maxwidth 80
$t configure -maxwidth 80 ;#review
append errmsg [$t print]
$t destroy
if {$returntype ne "tableobject"} {
#returntype of table means just the text of the table
$t destroy
}
} else {
append errmsg [join $errlines \n]
}
@ -1595,11 +1619,22 @@ tcl::namespace::eval punk::args {
}
set arg_error_isrunning 0
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
if {$returntype eq "error"} {
return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg
#Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
if {$use_table} {
#assert returntype is one of table, tableobject
set result $errmsg ;#default if for some reason table couldn't be used
if {$returntype eq "tableobject"} {
if {[info object isa object $t]} {
set result $t
}
}
} else {
return $errmsg
set result $errmsg
}
if {$as_error} {
return -code error -errorcode {TCL WRONGARGS PUNK} $result
} else {
return $result
}
}
@ -1609,17 +1644,21 @@ tcl::namespace::eval punk::args {
*proc -name punk::args::usage -help\
"return usage information as a string
in table form."
-return -default table -choices {string table tableobject}
*values -min 0 -max 1
id -help\
"exact id.
Will usually match the command name"
}]
proc usage {id} {
proc usage {args} {
lassign [dict values [punk::args::get_by_id punk::args::usage $args]] leaders opts values received
set id [dict get $values id]
set speclist [get_spec $id]
if {[llength $speclist] == 0} {
error "punk::args::usage - no such id: $id"
}
arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] -return string
arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] {*}$opts -aserror 0
}
lappend PUNKARGS [list {
@ -2726,7 +2765,7 @@ tcl::namespace::eval punk::args::lib {
*id punk::args::lib::tstr
*proc -name punk::args::lib::tstr -help\
"A rough equivalent of js template literals"
-allowcommands -default -1 -type none -help\
-allowcommands -default 0 -type none -help\
"if -allowcommands is present, placeholder can contain commands e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}"
-return -default list -choices {dict list string args}\
-choicelabels {

248
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm

@ -600,6 +600,48 @@ tcl::namespace::eval punk::char {
puts stdout \n
puts stdout "cursor position immediately after outputing 3 bytes (xyz): $cursorposn"
}
proc test_zalgo {} {
#from: https://github.com/jameslanska/unicode-display-width/blob/5e28d94c75e8c421a87199363b85c90dc37125b8/docs/unicode_background.md
#see: https://lingojam.com/ZalgoText
puts stdout "44 chars long - 9 graphemes - 9 columns wide"
set str "Ẓ̌á̲l͔̝̞̄̑͌g̖̘̘̔̔͢͞͝o̪̔T̢̙̫̈̍͞e̬͈͕͌̏͑x̺̍̓̓ͅ"
}
proc test_zalgo2 {} {
# ------------------------
set str "Z̸̢͉̣͔̭̪͙̖̳̘͈͍̤̩̟͈͈͕̯̅̏̆̓̌́́͌̿̕ͅą̷̦̤̫̩͕̥̐̎̓́́̂̀͆́̔̄̈́̏̌́̆͜͜͝͠l̴̩̙̺͚̟͇͖͔͕̹̟͌̈́̄̇́̉̋̕̚͜͠͠g̸͇̩͔̺̝̗̥̖̙̑̈́̈́̿̾̌͌͊̈̀͊̑̇̑͌̍̅̌͊͜͠͝ǫ̴̢̧͎͔̞̤̻̱̮̬͕̗̭͍̣̠̳̆̀̋̓͒̾̄͜͝͠͝T̴̛͉̬̋́̈́̈́̓͗̍̏̔̈̋̀͐̓̎̅̚̕͠͝͝ê̵̖̖̈͊̔̓̔̐̓̃͊̋͋̎͂͋̕x̴̡͎͖̼͎̦͎̲̪̘̺̯̲̬̮̥̼̰͌̃͜ͅt̶̛̘͎̰̔͐͌́̈́͊͗͌̅͂̐̆͌̀͂͘"
# ------------------------
}
proc test_zalgo3 {} {
# ------------------------
set str "Ẕ̸̢̼̺̜̰̣̣̖̭̜͓͖̺̥̼̠͙͙̟̥̟̠̤̫͍̠̤̮͚̝̜̙͈̦̙̩̹̙̜̩̦͔͕̈̃̅̇̈́͂̇̽̈́́́́̎͊̂̑̋͆̔̾͋̚͜ͅã̵̛̪̽̎̃͑̒̇͋͂̽̃̍͊̀̈̊̊̔̊̆̈́͗͑͗̽̄̋͗̄͌̑͊͝͝͠ͅl̵̢͇̖͉͖̝̹̜̞͓͎͍͈̞̱̙͙̦̪͔̱̮͈͉̼͎̭̝̯͇͚̺̟̱͙̳̰̙͚͖̝̫͙̎̅̃͆̈́̋̌̔̋̋͗̈́̔̐͆̈́̓̾̄̀́̏́͒̆̌͒̈́̈́̾̏̀͜͝g̸̖͂͋̊͗̈́̓̆̈̋̒͐̕o̶̧̢͓̲̗̠̘͕̦̤̹̗͉̰͔̯͓̭̹̻͔͇̯̜̙̍̂̃̃̀̓͌̒͊̊̋̒̿̿̌͐̄͗̾̕͝T̶̛̳̜̰͍̹̻̫̠̱̼̼̙̆̑̾̾͛́́̿͋͌̎̀̀̽̆͌̽̂̈̇̅̇̃́̿͗̾͒̎͊̑̾͝͠ȩ̸̢̨̛̛̛̭͔͎͇̫͎͈̲̻̙͕͎̣͈̩̺̗͖͙͇͌͐̒̎͐̓́̉́͐̓̐͌̅̊͋͑̈́͗͑̏̕͜͜͝ͅx̸̧̧̛̖̣̥̘͎͎̳̭̙̦̝͖̝̮̱̹̯̺̙̩̯̮͖̻̰͓̰̩͇̥̑͌̊̐̉̏͆̓̑̎̊̓͒̂̄̆͆̀̊̄̈̽͐͛̏͊̓̌͑́̎̈́̍̈́̊͗̉̋͆̿̊͘͜͜͝͝ͅͅͅt̵̡̨̜̘͎̦͚̠̗̺͉̼̠̲̠͙̺̹̗̲̏̈́̂̚͜͜͝ͅ"
# ------------------------
}
proc test_farmer {} {
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
@ -620,17 +662,29 @@ tcl::namespace::eval punk::char {
puts stdout "farmer2 with no joiner codes: \\U0001f9d1\\U001f33e : $farmer2"
package require punk::console
puts stdout \n
puts stdout "#2--5---9---C---"
puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1
puts -nonewline "${farmer1}";set cursorposn [punk::console::get_cursor_pos]
puts stdout \n
puts stdout "cursor position immediately after outputing farmer1 (expecting 1 glyph 2 wide) : $cursorposn"
puts -nonewline "${farmer1}";set cursorposn [punk::console::get_cursor_pos_list]
puts stdout "\ncursor position immediately after outputing farmer1 (expecting 1 glyph 2 wide) : cursor at col [lindex $cursorposn 1]"
if {[lindex $cursorposn 1] eq "3"} {
puts stdout "[a+ green]OK[a]"
} else {
puts stdout "[a+ red]ERR - expected cursor position to be 3 after emitting farmer1[a]"
}
puts stdout "----------------"
puts stdout "#2--5---9---C---"
puts -nonewline "${farmer2}";set cursorposn [punk::console::get_cursor_pos]
puts stdout \n
puts stdout "cursor position immediately after outputing farmer2 (expecting 2 glyphs 4 wide in total): $cursorposn"
puts -nonewline "${farmer2}";set cursorposn [punk::console::get_cursor_pos_list]
puts stdout "\ncursor position immediately after outputing farmer2 (expecting 2 glyphs 4 wide in total): cursor at col [lindex $cursorposn 1]"
if {[lindex $cursorposn 1] eq "5"} {
puts stdout "[a+ green]OK[a]"
} else {
puts stdout "[a+ red]ERR - expected cursor position to be 5 after emitting farmer2[a]"
}
puts stdout "----------------"
return [list $farmer1 $farmer2]
puts "returning farmer1 - should be single glyph"
return $farmer1
}
#G0 Sets Sequence G1 Sets Sequence Meaning
@ -1916,6 +1970,172 @@ tcl::namespace::eval punk::char {
# - tab/vtab?
# - compare with wcswidth returning -1 for entire string containing such in python,perl
proc wcswidth {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?)
#Tcl initial evaluation stack size is 2000 (? review)
#REVIEW - when we cater for grapheme clusters - we can't just split the string at arbitrary points like this!!
set chunksize 2000
set chunks_required [expr {int(ceil([tcl::string::length $string] / double($chunksize)))}]
set width 0
set startidx 0
set endidx [expr {$startidx + $chunksize -1}]
for {set i 0} {$i < $chunks_required} {incr i} {
set chunk [tcl::string::range $string $startidx $endidx]
set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]]
foreach c $codes {
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
incr startidx $chunksize
incr endidx $chunksize
}
return $width
}
# ------------------------------------------------------------------------------------------------------
#test
# ------------------------------------------------------------------------------------------------------
proc grapheme_split_tk {string} {
if {![regexp "\[\uFF-\U10FFFF\]" $string]} {
#only ascii - no joiners or unicode
return [split $string {}]
}
package require tk
set i 0
set graphemes [list]
while {$i < [tcl::string::length $string]} {
set aftercluster [tk::endOfCluster $string $i]
lappend graphemes [string range $string $i $aftercluster-1]
set i $aftercluster
}
return $graphemes
}
proc wcswidth_clustered {string} {
package require tk
set width 0
set i 0
if {![regexp "\[\uFF-\U10FFFF\]" $string]} {
return [punk::char::wcswidth_unclustered $string] ;#still use our wcswidth to account for non-printable ascii
}
while {$i < [tcl::string::length $string]} {
set aftercluster [tk::endOfCluster $string $i]
set g [string range $string $i $aftercluster-1]
if {$aftercluster > ($i + 1)} {
#review - proper way to determine screen width (columns occupied) of a cluster??
#according to this:
#https://lib.rs/crates/unicode-display-width
#for each grapheme - if any of the code points in the cluster have an east asian width of 2,
#The entire grapheme width is 2 regardless of how many code points constitute the grapheme
set gw 1
foreach ch [split $g ""] {
if {[punk::char::wcswidth_single $ch] == 2} {
set gw 2
break
}
}
incr width $gw
#if {[string first \u200d $g] >=0} {
# incr width 2
#} else {
# #other joiners???
# incr width [wcswidth_unclustered $g]
#}
} else {
incr width [wcswidth_unclustered $g]
}
set i $aftercluster
}
return $width
}
proc wcswidth_single {char} {
scan $c %c dec
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
return 1
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
return [textutil::wcswidth_char $c]
#may return -1 - REVIEW
}
return 0
}
proc wcswidth_unclustered1 {string} {
set width 0
foreach c [split $string {}] {
scan $c %c dec
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
return $width
}
#todo - consider disallowing/erroring out when \r \n in string?
# - tab/vtab?
# - compare with wcswidth returning -1 for entire string containing such in python,perl
proc wcswidth_unclustered {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?)
#Tcl initial evaluation stack size is 2000 (? review)
#we can only split the string at arbitrary points like this because we are specifically dealing with input that has no clusters!.
set chunksize 2000
set chunks_required [expr {int(ceil([tcl::string::length $string] / double($chunksize)))}]
set width 0
set startidx 0
set endidx [expr {$startidx + $chunksize -1}]
for {set i 0} {$i < $chunks_required} {incr i} {
set chunk [tcl::string::range $string $startidx $endidx]
set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]]
foreach c $codes {
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
incr startidx $chunksize
incr endidx $chunksize
}
return $width
}
# ------------------------------------------------------------------------------------------------------
proc wcswidth0 {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+
#TODO
@ -1943,20 +2163,6 @@ tcl::namespace::eval punk::char {
}
return $width
}
#faster than textutil::wcswidth (at least for string up to a few K in length)
proc wcswidth1 {string} {
set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]]
set width 0
foreach c $codes {
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
return $width
}
proc wcswidth2 {string} {
set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]]
set widths [lmap c $codes {textutil::wcswidth_char $c}]

1
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm

@ -875,6 +875,7 @@ namespace eval punk::console {
}
}
punk::args::set_alias punk::console::code_a+ punk::ansi::a+
proc code_a+ {args} {
variable ansi_wanted
if {$ansi_wanted <= 0} {

56
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm

@ -962,21 +962,6 @@ namespace eval punk::lib {
namespace import ::punk::args::lib::tstr
#get info about punk nestindex key ie type: list,dict,undetermined
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
}
proc invoke command {
@ -1127,17 +1112,35 @@ namespace eval punk::lib {
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
-keysorttype -default "none" -choices {none dictionary ascii integer real}
-keysortdirection -default increasing -choices {increasing decreasing}
-debug -default 0 -type boolean -help\
"When enabled, produces some rudimentary debug output on stderr"
*values -min 1 -max -1
dictvalue -type list -help "dict or list value"
patterns -default "*" -type string -multiple 1 -help "key or key glob pattern"
}] $args]
#for punk::lib - we want to reduce pkg dependencies.
# - so we won't even use the tcllib debug pkg here
set opt_debug [dict get $argd opts -debug]
if {$opt_debug} {
if {[info body debug::showdict] eq ""} {
proc ::punk::lib::debug::showdict {args} {
catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"}
}
}
} else {
if {[info body debug::showdict] ne ""} {
proc ::punk::lib::debug::showdict {args} {}
}
}
set opt_sep [dict get $argd opts -separator]
set opt_mismatch_sep [dict get $argd opts -separator_mismatch]
set opt_keysorttype [dict get $argd opts -keysorttype]
set opt_keysortdirection [dict get $argd opts -keysortdirection]
set opt_trimright [dict get $argd opts -trimright]
set opt_keytemplates [dict get $argd opts -keytemplates]
puts stderr "---> $opt_keytemplates <---"
debug::showdict "keytemplates ---> $opt_keytemplates <---"
set opt_ansibase_keys [dict get $argd opts -ansibase_keys]
set opt_ansibase_values [dict get $argd opts -ansibase_values]
set opt_return [dict get $argd opts -return]
@ -4112,10 +4115,31 @@ tcl::namespace::eval punk::lib::system {
return $incomplete
}
#get info about punk nestindex key ie type: list,dict,undetermined
# pdict devel
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
#???
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
}
tcl::namespace::eval punk::lib::debug {
proc showdict {args} {}
}
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace

22
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm

@ -1896,6 +1896,10 @@ tcl::namespace::eval punk::ns {
*id punk::ns::arginfo
*proc -name punk::ns::arginfo -help\
"Show usage info for a command"
-return -type string -default table -choices {string table tableobject}
-- -type none -help\
"End of options marker
Use this if the command to view begins with a -"
*values -min 1
commandpath -help\
"command (may be alias or ensemble)"
@ -2050,7 +2054,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$origin new"]
return [punk::args::usage {*}$opts "$origin new"]
}
create {
set constructorinfo [info class constructor $origin]
@ -2079,7 +2083,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$origin create"]
return [punk::args::usage {*}$opts "$origin create"]
}
destroy {
#review - generally no doc
@ -2092,7 +2096,7 @@ tcl::namespace::eval punk::ns {
*values -min 0 -max 0
}]
punk::args::definition $argspec
return [punk::args::usage "$origin destroy"]
return [punk::args::usage {*}$opts "$origin destroy"]
}
default {
#use info object call <obj> <method> to resolve callchain
@ -2112,7 +2116,7 @@ tcl::namespace::eval punk::ns {
set id "[string trimleft $origin :] $c1" ;# "<object> <method>"
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set def [::info object definition $origin $c1]
@ -2120,7 +2124,7 @@ tcl::namespace::eval punk::ns {
set id "[string trimleft $location :] $c1" ;# "<class> <method>"
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set def [::info class definition $location $c1]
@ -2162,7 +2166,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$location $c1"]
return [punk::args::usage {*}$opts "$location $c1"]
} else {
return "unable to resolve $origin method $c1"
}
@ -2216,7 +2220,7 @@ tcl::namespace::eval punk::ns {
}]
append argspec \n $vline
punk::args::definition $argspec
return [punk::args::usage $origin]
return [punk::args::usage {*}$opts $origin]
}
privateObject {
return "Command is a privateObject - no info currently available"
@ -2327,7 +2331,7 @@ tcl::namespace::eval punk::ns {
}]
append argspec \n $vline
punk::args::definition $argspec
return [punk::args::usage $origin]
return [punk::args::usage {*}$opts $origin]
}
#check for tepam help
@ -2363,7 +2367,7 @@ tcl::namespace::eval punk::ns {
set id [string trimleft $origin :]
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set origin_ns [nsprefix $origin]

2
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm

@ -190,7 +190,7 @@ tcl::namespace::eval punk::repl::codethread {
if {[llength $::codeinterp::run_command_cache] > 2000} {
set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache]
}
if {[string first ":::" $::punk::ns::ns_current]} {
if {[string first ":::" $::punk::ns::ns_current] >= 0} {
#support for browsing 'odd' (inadvisable) namespaces
#don't use 'namespace exists' - will conflate ::test::x with ::test:::x
#if {$::punk::ns::ns_current in [namespace children [punk::ns::nsprefix $::punk::ns::ns_current]} {

225
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm

@ -299,6 +299,9 @@ tcl::namespace::eval textblock {
#It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp.
#e.g $t configure -framemap_body [table_edge_map " "]
# -- --- --- --- ---
#unused?
proc table_edge_map {char} {
variable table_edge_parts
set map [list]
@ -335,6 +338,7 @@ tcl::namespace::eval textblock {
}
return $map
}
# -- --- --- --- ---
if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} {
#*** !doctools
@ -374,6 +378,7 @@ tcl::namespace::eval textblock {
variable o_columndefs
variable o_columndata
variable o_columnstates
variable o_headerdefs
variable o_headerstates
variable o_rowdefs
@ -432,6 +437,7 @@ tcl::namespace::eval textblock {
set o_columndefs [tcl::dict::create]
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_headerdefs [tcl::dict::create] ;#by header-row
set o_headerstates [tcl::dict::create]
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
@ -439,12 +445,14 @@ tcl::namespace::eval textblock {
set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices.
set o_calculated_column_widths [list]
set o_column_width_algorithm "span"
set header_defaults [tcl::dict::create\
set o_opts_header_defaults [tcl::dict::create\
-colspans {}\
-values {}\
-ansibase {}\
-ansireset "\x1b\[m"\
-minheight 1\
-maxheight ""\
]
set o_opts_header_defaults $header_defaults
}
method width_algorithm {{alg ""}} {
@ -1107,10 +1115,18 @@ tcl::namespace::eval textblock {
}
}
}
#args checked - ok to update headerstates and columndefs and columnstates
#args checked - ok to update headerstates, headerdefs and columndefs and columnstates
tcl::dict::set o_columndefs $cidx $checked_opts
set o_headerstates $hstates
dict for {hidx hstate} $hstates {
#configure_header
if {![dict exists $o_headerdefs $hidx]} {
#remove calculated members -values -colspans
set hdefaults [dict remove $o_opts_header_defaults -values -colspans]
dict set o_headerdefs $hidx $hdefaults
}
}
tcl::dict::set o_columnstates $cidx $colstate
if {$args_got_headers} {
@ -1267,11 +1283,10 @@ tcl::namespace::eval textblock {
return $hcolspans
}
#should be configure_headerrow ?
method configure_header {index_expression args} {
#*** !doctools
#[call class::table [method configure_header]]
#[para] - undocumented
#[para] - configure header row-wise
#the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs.
#It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis
@ -1279,7 +1294,7 @@ tcl::namespace::eval textblock {
set num_headers [my header_count_calc]
set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression]
if {$hidx eq ""} {
error "textblock::table::configure_header - no row defined at index '$hidx'."
error "textblock::table::configure_header - no header row defined at index '$index_expression'."
}
if {$hidx > $num_headers -1} {
#assert - shouldn't happen
@ -1298,6 +1313,14 @@ tcl::namespace::eval textblock {
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
}
tcl::dict::set result -values $header_row_items
#review - ensure always a headerdef record for each header?
if {[tcl::dict::exists $o_headerdefs $hidx]} {
set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]]
} else {
#warn for now
puts stderr "no headerdef record for header $hidx"
}
return $result
}
if {[llength $args] == 1} {
@ -1328,7 +1351,8 @@ tcl::namespace::eval textblock {
set colspans_by_header [my header_colspans]
set result [tcl::dict::create]
set val [tcl::dict::get $colspans_by_header $hidx]
set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"]
#ansireset not required
set returndict [tcl::dict::create option $k value $val]
}
-ansibase {
set val ???
@ -1369,8 +1393,7 @@ tcl::namespace::eval textblock {
lappend header_ansibase_items $code
}
}
set header_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items]
error "sorry - -ansibase not yet implemented for header rows"
set header_ansibase [punk::ansi::codetype::sgr_merge_singles $header_ansibase_items]
lappend checked_opts $k $header_ansibase
}
-ansireset {
@ -1472,6 +1495,10 @@ tcl::namespace::eval textblock {
#safe jumptable test
#dict for {k v} $checked_opts {}
#foreach {k v} $checked_opts {}
# headerdefs excludes -values and -colspans
set update_hdefs [tcl::dict::get $o_headerdefs $hidx]
tcl::dict::for {k v} $checked_opts {
switch -- $k {
-values {
@ -1538,8 +1565,28 @@ tcl::namespace::eval textblock {
incr c
}
}
default {
dict set update_hdefs $k $v
}
}
}
set opt_minh [tcl::dict::get $update_hdefs -minheight]
set opt_maxh [tcl::dict::get $update_hdefs -maxheight]
#todo - allow zero values to hide/collapse
# - see also configure_row
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
}
#set o_headerstate $hidx -minheight? -maxheight? ???
tcl::dict::set o_headerdefs $hidx $update_hdefs
}
method add_row {valuelist args} {
@ -2050,7 +2097,8 @@ tcl::namespace::eval textblock {
foreach header $header_list {
set headerspans [tcl::dict::get $all_colspans $hrow]
set this_span [lindex $headerspans $cidx]
set hval $ansibase_header$header ;#no reset
#set hval $ansibase_header$header ;#no reset
set hval $header
set rowh [my header_height $hrow]
if {$hrow == 0} {
@ -2317,7 +2365,7 @@ tcl::namespace::eval textblock {
set h_lines [lrepeat $rowh $bline]
set hcell_blank [::join $h_lines \n]
# -usecache 1 ok
#frame borders will never display - so use the simplest frametype and don't apply any ansi
#frame borders will never display - so use the simplest frametype and don't apply any ansi
#puts "===>zerospan hlims: $hlims"
set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\
-boxlimits $hlims -boxmap $framesub_map $hcell_blank\
@ -2589,8 +2637,8 @@ tcl::namespace::eval textblock {
}
}
set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body]
set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header]
#set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body]
#set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header]
#set header_underlay $ansibase_header$cell_line_blank
@ -2613,7 +2661,35 @@ tcl::namespace::eval textblock {
set showing_vseps [my Showing_vseps]
for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} {
set hdr [lindex $headerlist $hrow]
set header_maxdataheight [my header_height $hrow] ;#from cached headerstates
#jjj
set header_maxdataheight [tcl::dict::get $o_headerstates $hrow maxheightseen]
#set header_maxdataheight [my header_height $hrow] ;#from cached headerstates
set headerdefminh [tcl::dict::get $o_headerdefs $hrow -minheight]
set headerdefmaxh [tcl::dict::get $o_headerdefs $hrow -maxheight]
if {"$headerdefminh$headerdefmaxh" ne "" && $headerdefminh eq $headerdefmaxh} {
set headerh $headerdefminh ;#exact height defined for the row
} else {
if {$headerdefminh eq ""} {
if {$headerdefmaxh eq ""} {
#both defs empty
set headerh $header_maxdataheight
} else {
set headerh [expr {min(1,$headerdefmaxh,$header_maxdataheight)}]
}
} else {
if {$headerdefmaxh eq ""} {
set headerh [expr {max($headerdefminh,$header_maxdataheight)}]
} else {
if {$header_maxdataheight < $headerdefminh} {
set headerh $headerdefminh
} else {
set headerh [expr {max($headerdefminh,$header_maxdataheight)}]
}
}
}
}
set headerrow_colspans [tcl::dict::get $all_colspans $hrow]
set this_span [lindex $headerrow_colspans $cidx]
@ -2654,8 +2730,7 @@ tcl::namespace::eval textblock {
set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight]
set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight]
if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} {
#an exact height is defined for the row
set rowh $rowdefminh
set rowh $rowdefminh ;#an exact height is defined for the row
} else {
if {$rowdefminh eq ""} {
if {$rowdefmaxh eq ""} {
@ -2814,6 +2889,7 @@ tcl::namespace::eval textblock {
$t destroy
}
puts stdout "columnstates: $o_columnstates"
puts stdout "headerdefs: $o_headerdefs"
puts stdout "headerstates: $o_headerstates"
tcl::dict::for {k coldef} $o_columndefs {
if {[tcl::dict::exists $o_columndata $k]} {
@ -4205,6 +4281,68 @@ tcl::namespace::eval textblock {
return $t
}
proc bookend_lines {block start {end "\x1b\[m"}} {
set out ""
foreach ln [split $block \n] {
append out $start $ln $end \n
}
return [string range $out 0 end-1]
}
proc ansibase_lines {block {newprefix ""}} {
set base ""
set out ""
if {$newprefix eq ""} {
foreach ln [split $block \n] {
set parts [punk::ansi::ta::split_codes $ln]
if {[lindex $parts 0] eq ""} {
if {[lindex $parts 1] ne "" && ![punk::ansi::codetype::is_sgr_reset [lindex $parts 1]]} {
set base [lindex $parts 1]
append out $base
} else {
append out $base
}
} else {
#leading plaintext - maintain our base
append out $base [lindex $parts 0] [lindex $parts 1]
}
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]
}
incr code_idx 2
}
append out {*}[lrange $parts 2 end] \n
}
return [string range $out 0 end-1]
} else {
set base $newprefix
foreach ln [split $block \n] {
set parts [punk::ansi::ta::split_codes $ln]
set code_idx 1
set offset 0
foreach {pt code} $parts {
if {$code_idx == 1} {
#first pt & code
if {$pt ne ""} {
#leading plaintext
set parts [linsert $parts 0 $base]
incr offset
}
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts [expr {$code_idx+1+$offset}] $base]
incr offset
}
incr code_idx 2
}
append out {*}$parts \n
}
return [string range $out 0 end-1]
}
}
set FRAMETYPES [textblock::frametypes]
punk::args::definition [punk::lib::tstr -return string {
*id textblock::list_as_table
@ -4606,12 +4744,22 @@ tcl::namespace::eval textblock {
return [punk::char::ansifreestring_width $tl]
}
#uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function.
proc string_length_line_max textblock {
tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
proc string_length_line_max {textblock} {
#tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
set max 0
foreach ln [split $textblock \n] {
if {[tcl::string::length $ln] > $max} {set max [tcl::string::length $ln]}
}
return $max
}
#*slightly* slower
#proc string_length_line_max {textblock} {
# tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
#}
proc string_length_line_min textblock {
tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
}
proc height {textblock} {
#This is the height as it will/would-be rendered - not the number of input lines purely in terms of le
#empty string still has height 1 (at least for left-right/right-left languages)
@ -4652,6 +4800,45 @@ tcl::namespace::eval textblock {
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size2 {textblock} {
if {$textblock eq ""} {
return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack
if {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
set lines [split $textblock \n]
set num_le [expr {[llength $lines]-1}]
#set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]]
set width 0
foreach ln $lines {
set w [::punk::char::ansifreestring_width $ln]
if {$w > $width} {
set width $w
}
}
} else {
set num_le 0
set width [punk::char::ansifreestring_width $textblock]
}
#set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list
#our concept of block-height is likely to be different to other line-counting mechanisms
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size_as_opts {textblock} {
set sz [size $textblock]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]

44
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm

@ -729,7 +729,7 @@ tcl::namespace::eval overtype {
-width [tcl::dict::get $vtstate renderwidth]\
-insert_mode [tcl::dict::get $vtstate insert_mode]\
-autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\
-expand_right [tcl::dict::get $opts -opt_expand_right]\
-expand_right [tcl::dict::get $opts -expand_right]\
""\
$overflow_right\
]
@ -1366,7 +1366,7 @@ tcl::namespace::eval overtype {
if {$overflowlength > 0} {
#overlay line wider or equal
#review - we still expand_right for centred for now.. possibly should expand_both with ellipsis each end?
#review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end?
set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
@ -1771,7 +1771,7 @@ tcl::namespace::eval overtype {
#-returnextra enables returning of overflow and length
#review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation?
#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements
#(could render it by faking it with sixels and a lot of work - find/make a sixel font (converter?) and ensure it's exactly 2 cols per char?
#(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char?
# This would probably be impractical to support for different fonts)
#todo - review transparency issues with single/double width characters
#bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer?
@ -2815,6 +2815,7 @@ tcl::namespace::eval overtype {
\x1b\[< 1006\
\x1b\[ 7CSI\
\x1bP 7DCS\
\x90 8DCS\
\x9b 8CSI\
\x1b\] 7OSC\
\x9d 8OSC\
@ -2836,6 +2837,10 @@ tcl::namespace::eval overtype {
#Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]]
}
8DCS {
#8-bit Device Control String
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
7ESC {
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
@ -3265,6 +3270,17 @@ tcl::namespace::eval overtype {
puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
T {
#CSI Pn T - SD Pan Up (empty lines introduced at top)
#CSI Pn+T - kitty extension (lines at top come from scrollback buffer)
#Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display
if {$param eq "" || $param eq "0"} {set param 1}
if {[string index $param end] eq "+"} {
puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
} else {
puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
X {
puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param"
#ECH - erase character
@ -3862,9 +3878,14 @@ tcl::namespace::eval overtype {
}
}
7DCS {
7DCS - 8DCS {
puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
#
#ST (string terminator) \x9c or \x1b\\
if {[tcl::string::index $codenorm end] eq "\x9c"} {
set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c
} else {
set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\
}
}
7OSC - 8OSC {
@ -3934,6 +3955,12 @@ tcl::namespace::eval overtype {
#tektronix cursor color
puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
99 {
#kitty desktop notifications
#https://sw.kovidgoyal.net/kitty/desktop-notifications/
#<OSC> 99 ; metadata ; payload <terminator>
puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
104 {
#reset colour palette
#we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt
@ -3942,6 +3969,13 @@ tcl::namespace::eval overtype {
set instruction [list reset_colour_palette]
break
}
1337 {
#iterm2 graphics and file transfer
puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]"
}
5113 {
puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]"
}
default {
puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}

164
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm

@ -101,12 +101,15 @@ set punk_testd2 [dict create \
] \
]
#impolitely cooperative withe punk repl - todo - tone it down.
#impolitely cooperative with punk repl - todo - tone it down.
#namespace eval ::punk::repl::codethread {
# variable running 0
#}
package require punk::lib
package require punk::lib ;# subdependency punk::args
package require punk::ansi
if {![llength [info commands ::ansistring]]} {
namespace import punk::ansi::ansistring
}
#require aliascore after punk::lib & punk::ansi are loaded
package require punk::aliascore ;#mostly punk::lib aliases
punk::aliascore::init
@ -114,9 +117,6 @@ punk::aliascore::init
package require punk::repl::codethread
package require punk::config
#package require textblock
if {![llength [info commands ::ansistring]]} {
namespace import punk::ansi::ansistring
}
package require punk::console
package require punk::ns
package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems
@ -862,6 +862,8 @@ namespace eval punk {
}
}
#? {
#review - compare to %# ?????
#seems to be unimplemented ?
set assigned [string length $leveldata]
set already_assigned 1
}
@ -7149,12 +7151,93 @@ namespace eval punk {
dict filter $result value {?*}
}
punk::args::definition {
*id punk::inspect
*proc -name punk::inspect -help\
"Function to display values - used pimarily in a punk pipeline.
The raw value arguments (not options) are always returned to pass
forward in the pipeline.
(pipeline data inserted at end of each |...> segment is passed as single item unless
inserted with an expanding insertion specifier such as .=>* )
e.g1:
.= list a b c |v1,/1-end,/0>\\
.=>* inspect -label i1 -- |>\\
.=v1> inspect -label i2 -- |>\\
string toupper
(3) i1: {a b c} {b c} a
(1) i2: a b c
- A B C
"
-label -type string -default "" -help\
"An optional label to help distinguish output when multiple
inspect statements are in a pipeline. This appears after the
bracketed count indicating number of values supplied.
e.g (2) MYLABEL: val1 val2
The label can include ANSI codes.
e.g
inspect -label [a+ red]mylabel -- val1 val2 val3
"
-limit -type int -default 20 -help\
"When multiple values are passed to inspect - limit the number
of elements displayed in -channel output.
When truncation has occured an elipsis indication (...) will be appended.
e.g
.= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+
(11) 20 23 26 29...
- 385
For no limit - use -limit -1
"
-channel -type string -default stderr -help\
"An existing open channel to write to. If value is any of nul, null, /dev/nul
the channel output is disabled. This effectively disables inspect as the args
are simply passed through in the return to continue the pipeline.
"
-showcount -type boolean -default 1 -help\
"Display a leading indicator in brackets showing the number of arg values present."
-ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels {
0 "Strip ANSI codes from display
of values. The disply output will
still be colourised if -ansibase has
not been set to empty string or
[a+ normal]. The stderr or stdout
channels may also have an ansi colour.
(see 'colour off' or punk::config)"
1 "Leave value as is"
2 "Display the ANSI codes and
other control characters inline
with replacement indicators.
e.g esc, newline, space, tab"
VIEW "Alias for 2"
3 "Display as per 2 but with
colourised ANSI replacement codes."
VIEWCODES "Alias for 3"
4 "Display ANSI and control
chars in default colour, but
apply the contained ansi to
the text portions so they display
as they would for -ansi 1"
VIEWSTYLE "Alias for 4"
}
-ansibase -type ansistring -default {${[a+ brightgreen]}} -help\
"Base ansi code(s) that will apply to output written to the chosen -channel.
If there are ansi resets in the displayed values - output will revert to this base.
Does not affect return value."
-- -type none -help\
"End of options marker.
It is advisable to use this, as data in a pipeline may often being with -"
*values -min 0 -max -1
arg -type string -optional 1 -multiple 1 -help\
"value to display"
}
#pipeline inspect
#e.g
#= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data}
proc inspect {args} {
set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1]
set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1 -ansibase [a+ brightgreen]]
set flags [list]
set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect --
if {$endoptsposn >= 0} {
@ -7177,24 +7260,28 @@ namespace eval punk {
}
foreach {k v} $flags {
if {$k ni [dict keys $defaults]} {
error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --"
#error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --"
punk::args::get_by_id punk::inspect $args
}
}
set opts [dict merge $defaults $flags]
# -- --- --- --- ---
set label [dict get $opts -label]
set channel [dict get $opts -channel]
set showcount [dict get $opts -showcount]
set label [dict get $opts -label]
set channel [dict get $opts -channel]
set showcount [dict get $opts -showcount]
if {[string length $label]} {
set label "${label}: "
}
set limit [dict get $opts -limit]
set opt_ansi [dict get $opts -ansi]
set opt_ansiraw [dict get $opts -ansi]
set opt_ansi [tcl::prefix::match -error "" [list 0 1 2 3 4 view viewcodes viewstyle] [string tolower $opt_ansiraw]]
switch -- [string tolower $opt_ansi] {
0 - 1 - 2 {}
view {set opt_ansi 2}
0 - 1 - 2 - 3 - 4 {}
view {set opt_ansi 2}
viewcodes {set opt_ansi 3}
viewstyle {set opt_ansi 4}
default {
error "inspect -ansi 0|1|2|view - received -ansi $opt_ansi"
error "inspect -ansi 0|1|2|view|3|viewcodes|4|viewstyle - received -ansi $opt_ansiraw"
}
}
# -- --- --- --- ---
@ -7248,15 +7335,50 @@ namespace eval punk {
} else {
set displaycount ""
}
if {$opt_ansi == 0} {
set displayval [punk::ansi::ansistrip $displayval]
} elseif {$opt_ansi == 2} {
set displayval [ansistring VIEW $displayval]
set ansibase [dict get $opts -ansibase]
if {$ansibase ne ""} {
#-ansibase default is hardcoded into punk::args definition
#run a test using any ansi code to see if colour is still enabled
if {[a+ red] eq ""} {
set ansibase "" ;#colour seems to be disabled
}
}
switch -- $opt_ansi {
0 {
set displayval $ansibase[punk::ansi::ansistrip $displayval]
}
1 {
#val may have ansi - including resets. Pass through ansibase_lines to
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
2 {
set displayval $ansibase[ansistring VIEW $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
3 {
set displayval $ansibase[ansistring VIEWCODE $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
4 {
set displayval $ansibase[ansistring VIEWSTYLE $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
}
if {![string length $more]} {
puts $channel "$displaycount$label[a green bold]$displayval[a]"
puts $channel "$displaycount$label$displayval[a]"
} else {
puts $channel "$displaycount$label[a green bold]$displayval[a yellow bold]$more[a]"
puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]"
}
return $val
}

19
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm

@ -167,6 +167,7 @@ tcl::namespace::eval punk::ansi::class {
}
default {
puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x"
punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args
}
}
}
@ -2415,6 +2416,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
*id punk::ansi::a+
*proc -name "punk::ansi::a+" -help\
"Returns an ANSI sgr escape sequence based on the list of supplied codes.
Unlike punk::ansi::a - it is not prefixed with an ANSI reset.
"
*values -min 0 -max -1
} [string map [list <choices> [dict keys $SGR_map]] {
@ -2432,10 +2434,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
The acceptable values for <termcolour> and <webcolour> can be queried using
punk::ansi::a? term
and
punk::ansi::a? web"
punk::ansi::a? web
Example to set foreground red and background cyan followed by a reset:
set str \"[a+ red Cyan]sample text[a]\"
"
}]]
proc a+ {args} {
#*** !doctools
#[call [fun a+] [opt {ansicode...}]]
@ -7065,13 +7069,12 @@ tcl::namespace::eval punk::ansi::ansistring {
}
}
#inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi
#todo - document
interp alias {} ansistring {} ::punk::ansi::ansistring
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}]
}
tcl::namespace::eval punk::ansi::control {
proc APC {args} {
return \x1b_[join $args {;}]\x1b\\
@ -7393,6 +7396,10 @@ tcl::namespace::eval punk::ansi::internal {
}
}
#inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi
#todo - document
interp alias {} ansistring {} ::punk::ansi::ansistring
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set NAMESPACES [list]

87
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm

@ -353,7 +353,7 @@ tcl::namespace::eval punk::args {
}
set optionspecs [join $normargs \n]
if {[string first \$\{ $optionspecs] > 0} {
set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 $optionspecs]]
set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]]
}
} else {
if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} {
@ -1262,30 +1262,43 @@ tcl::namespace::eval punk::args {
if {$arg_error_isrunning} {
error "arg_error already running - error in arg_error?\n triggering errmsg: $msg"
}
set arg_error_isrunning 1
if {[llength $args] %2 != 0} {
error "error in arg_error processing - expected opt/val pairs after msg and spec_dict"
}
set arg_error_isrunning 1
set badarg ""
set returntype error
set returntype table ;#table as string
set as_error 1 ;#usual case is to raise an error
dict for {k v} $args {
switch -- $k {
-badarg {
set badarg $v
}
-aserror {
if {![string is boolean -strict $v]} {
set arg_error_isrunning 0
error "arg_error invalid value for option -aserror. Received '$v' expected a boolean"
}
set as_error $v
}
-return {
if {$v ni {error string}} {
error "arg_error invalid value for option -return. Received '$v' expected one of: error string"
if {$v ni {string table tableobject}} {
set arg_error_isrunning 0
error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject"
}
set returntype $v
}
default {
set arg_error_isrunning 0
error "arg_error invalid option $k. Known_options: -badarg -return"
}
}
}
set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist.
#REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error
#e.g list_as_table
@ -1300,12 +1313,20 @@ tcl::namespace::eval punk::args {
#couldn't load textblock package
#just return the original errmsg without formatting
}
set use_table 0
if {$has_textblock && $returntype in {table tableobject}} {
set use_table 1
}
set errlines [list] ;#for non-textblock output
if {[catch {
if {$has_textblock} {
if {$use_table} {
append errmsg \n
} else {
append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n
if {($returntype in {table tableobject}) && !$has_textblock} {
append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n
} else {
append errmsg \n
}
}
set procname [Dict_getdef $spec_dict proc_info -name ""]
set prochelp [Dict_getdef $spec_dict proc_info -help ""]
@ -1333,7 +1354,7 @@ tcl::namespace::eval punk::args {
} else {
set docurl_display ""
}
if {$has_textblock} {
if {$use_table} {
set t [textblock::class::table new [a+ brightyellow]Usage[a]]
$t add_column -headers $blank_header_col -minwidth 3
$t add_column -headers $blank_header_col
@ -1343,7 +1364,7 @@ tcl::namespace::eval punk::args {
}
set h 0
if {$procname ne ""} {
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display]
} else {
lappend errlines "PROC/METHOD: $procname_display"
@ -1351,7 +1372,7 @@ tcl::namespace::eval punk::args {
incr h
}
if {$prochelp ne ""} {
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list Description: $prochelp_display]
} else {
lappend errlines "Description: $prochelp_display"
@ -1362,14 +1383,14 @@ tcl::namespace::eval punk::args {
if {![catch {package require punk::ansi}]} {
set docurl [punk::ansi::hyperlink $docurl]
}
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list $docname $docurl_display]
} else {
lappend errlines "$docname $docurl_display"
}
incr h
}
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -values {Arg Type Default Multi Help}
} else {
lappend errlines " --ARGUMENTS-- "
@ -1519,7 +1540,7 @@ tcl::namespace::eval punk::args {
set numcols [llength $formattedchoices]
}
if {$numcols > 0} {
if {$has_textblock} {
if {$use_table} {
#risk of recursing
set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices]
append help \n[textblock::join -- " " $choicetable]
@ -1565,7 +1586,7 @@ tcl::namespace::eval punk::args {
append typeshow \n "-range [dict get $arginfo -range]"
}
if {$has_textblock} {
if {$use_table} {
$t add_row [list $argshow $typeshow $default $multiple $help]
if {$arg eq $badarg} {
$t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG
@ -1577,11 +1598,14 @@ tcl::namespace::eval punk::args {
}
}
if {$has_textblock} {
if {$use_table} {
$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow]
$t configure -maxwidth 80
$t configure -maxwidth 80 ;#review
append errmsg [$t print]
$t destroy
if {$returntype ne "tableobject"} {
#returntype of table means just the text of the table
$t destroy
}
} else {
append errmsg [join $errlines \n]
}
@ -1595,11 +1619,22 @@ tcl::namespace::eval punk::args {
}
set arg_error_isrunning 0
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
if {$returntype eq "error"} {
return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg
#Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
if {$use_table} {
#assert returntype is one of table, tableobject
set result $errmsg ;#default if for some reason table couldn't be used
if {$returntype eq "tableobject"} {
if {[info object isa object $t]} {
set result $t
}
}
} else {
return $errmsg
set result $errmsg
}
if {$as_error} {
return -code error -errorcode {TCL WRONGARGS PUNK} $result
} else {
return $result
}
}
@ -1609,17 +1644,21 @@ tcl::namespace::eval punk::args {
*proc -name punk::args::usage -help\
"return usage information as a string
in table form."
-return -default table -choices {string table tableobject}
*values -min 0 -max 1
id -help\
"exact id.
Will usually match the command name"
}]
proc usage {id} {
proc usage {args} {
lassign [dict values [punk::args::get_by_id punk::args::usage $args]] leaders opts values received
set id [dict get $values id]
set speclist [get_spec $id]
if {[llength $speclist] == 0} {
error "punk::args::usage - no such id: $id"
}
arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] -return string
arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] {*}$opts -aserror 0
}
lappend PUNKARGS [list {
@ -2726,7 +2765,7 @@ tcl::namespace::eval punk::args::lib {
*id punk::args::lib::tstr
*proc -name punk::args::lib::tstr -help\
"A rough equivalent of js template literals"
-allowcommands -default -1 -type none -help\
-allowcommands -default 0 -type none -help\
"if -allowcommands is present, placeholder can contain commands e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}"
-return -default list -choices {dict list string args}\
-choicelabels {

248
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm

@ -600,6 +600,48 @@ tcl::namespace::eval punk::char {
puts stdout \n
puts stdout "cursor position immediately after outputing 3 bytes (xyz): $cursorposn"
}
proc test_zalgo {} {
#from: https://github.com/jameslanska/unicode-display-width/blob/5e28d94c75e8c421a87199363b85c90dc37125b8/docs/unicode_background.md
#see: https://lingojam.com/ZalgoText
puts stdout "44 chars long - 9 graphemes - 9 columns wide"
set str "Ẓ̌á̲l͔̝̞̄̑͌g̖̘̘̔̔͢͞͝o̪̔T̢̙̫̈̍͞e̬͈͕͌̏͑x̺̍̓̓ͅ"
}
proc test_zalgo2 {} {
# ------------------------
set str "Z̸̢͉̣͔̭̪͙̖̳̘͈͍̤̩̟͈͈͕̯̅̏̆̓̌́́͌̿̕ͅą̷̦̤̫̩͕̥̐̎̓́́̂̀͆́̔̄̈́̏̌́̆͜͜͝͠l̴̩̙̺͚̟͇͖͔͕̹̟͌̈́̄̇́̉̋̕̚͜͠͠g̸͇̩͔̺̝̗̥̖̙̑̈́̈́̿̾̌͌͊̈̀͊̑̇̑͌̍̅̌͊͜͠͝ǫ̴̢̧͎͔̞̤̻̱̮̬͕̗̭͍̣̠̳̆̀̋̓͒̾̄͜͝͠͝T̴̛͉̬̋́̈́̈́̓͗̍̏̔̈̋̀͐̓̎̅̚̕͠͝͝ê̵̖̖̈͊̔̓̔̐̓̃͊̋͋̎͂͋̕x̴̡͎͖̼͎̦͎̲̪̘̺̯̲̬̮̥̼̰͌̃͜ͅt̶̛̘͎̰̔͐͌́̈́͊͗͌̅͂̐̆͌̀͂͘"
# ------------------------
}
proc test_zalgo3 {} {
# ------------------------
set str "Ẕ̸̢̼̺̜̰̣̣̖̭̜͓͖̺̥̼̠͙͙̟̥̟̠̤̫͍̠̤̮͚̝̜̙͈̦̙̩̹̙̜̩̦͔͕̈̃̅̇̈́͂̇̽̈́́́́̎͊̂̑̋͆̔̾͋̚͜ͅã̵̛̪̽̎̃͑̒̇͋͂̽̃̍͊̀̈̊̊̔̊̆̈́͗͑͗̽̄̋͗̄͌̑͊͝͝͠ͅl̵̢͇̖͉͖̝̹̜̞͓͎͍͈̞̱̙͙̦̪͔̱̮͈͉̼͎̭̝̯͇͚̺̟̱͙̳̰̙͚͖̝̫͙̎̅̃͆̈́̋̌̔̋̋͗̈́̔̐͆̈́̓̾̄̀́̏́͒̆̌͒̈́̈́̾̏̀͜͝g̸̖͂͋̊͗̈́̓̆̈̋̒͐̕o̶̧̢͓̲̗̠̘͕̦̤̹̗͉̰͔̯͓̭̹̻͔͇̯̜̙̍̂̃̃̀̓͌̒͊̊̋̒̿̿̌͐̄͗̾̕͝T̶̛̳̜̰͍̹̻̫̠̱̼̼̙̆̑̾̾͛́́̿͋͌̎̀̀̽̆͌̽̂̈̇̅̇̃́̿͗̾͒̎͊̑̾͝͠ȩ̸̢̨̛̛̛̭͔͎͇̫͎͈̲̻̙͕͎̣͈̩̺̗͖͙͇͌͐̒̎͐̓́̉́͐̓̐͌̅̊͋͑̈́͗͑̏̕͜͜͝ͅx̸̧̧̛̖̣̥̘͎͎̳̭̙̦̝͖̝̮̱̹̯̺̙̩̯̮͖̻̰͓̰̩͇̥̑͌̊̐̉̏͆̓̑̎̊̓͒̂̄̆͆̀̊̄̈̽͐͛̏͊̓̌͑́̎̈́̍̈́̊͗̉̋͆̿̊͘͜͜͝͝ͅͅͅt̵̡̨̜̘͎̦͚̠̗̺͉̼̠̲̠͙̺̹̗̲̏̈́̂̚͜͜͝ͅ"
# ------------------------
}
proc test_farmer {} {
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
@ -620,17 +662,29 @@ tcl::namespace::eval punk::char {
puts stdout "farmer2 with no joiner codes: \\U0001f9d1\\U001f33e : $farmer2"
package require punk::console
puts stdout \n
puts stdout "#2--5---9---C---"
puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1
puts -nonewline "${farmer1}";set cursorposn [punk::console::get_cursor_pos]
puts stdout \n
puts stdout "cursor position immediately after outputing farmer1 (expecting 1 glyph 2 wide) : $cursorposn"
puts -nonewline "${farmer1}";set cursorposn [punk::console::get_cursor_pos_list]
puts stdout "\ncursor position immediately after outputing farmer1 (expecting 1 glyph 2 wide) : cursor at col [lindex $cursorposn 1]"
if {[lindex $cursorposn 1] eq "3"} {
puts stdout "[a+ green]OK[a]"
} else {
puts stdout "[a+ red]ERR - expected cursor position to be 3 after emitting farmer1[a]"
}
puts stdout "----------------"
puts stdout "#2--5---9---C---"
puts -nonewline "${farmer2}";set cursorposn [punk::console::get_cursor_pos]
puts stdout \n
puts stdout "cursor position immediately after outputing farmer2 (expecting 2 glyphs 4 wide in total): $cursorposn"
puts -nonewline "${farmer2}";set cursorposn [punk::console::get_cursor_pos_list]
puts stdout "\ncursor position immediately after outputing farmer2 (expecting 2 glyphs 4 wide in total): cursor at col [lindex $cursorposn 1]"
if {[lindex $cursorposn 1] eq "5"} {
puts stdout "[a+ green]OK[a]"
} else {
puts stdout "[a+ red]ERR - expected cursor position to be 5 after emitting farmer2[a]"
}
puts stdout "----------------"
return [list $farmer1 $farmer2]
puts "returning farmer1 - should be single glyph"
return $farmer1
}
#G0 Sets Sequence G1 Sets Sequence Meaning
@ -1916,6 +1970,172 @@ tcl::namespace::eval punk::char {
# - tab/vtab?
# - compare with wcswidth returning -1 for entire string containing such in python,perl
proc wcswidth {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?)
#Tcl initial evaluation stack size is 2000 (? review)
#REVIEW - when we cater for grapheme clusters - we can't just split the string at arbitrary points like this!!
set chunksize 2000
set chunks_required [expr {int(ceil([tcl::string::length $string] / double($chunksize)))}]
set width 0
set startidx 0
set endidx [expr {$startidx + $chunksize -1}]
for {set i 0} {$i < $chunks_required} {incr i} {
set chunk [tcl::string::range $string $startidx $endidx]
set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]]
foreach c $codes {
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
incr startidx $chunksize
incr endidx $chunksize
}
return $width
}
# ------------------------------------------------------------------------------------------------------
#test
# ------------------------------------------------------------------------------------------------------
proc grapheme_split_tk {string} {
if {![regexp "\[\uFF-\U10FFFF\]" $string]} {
#only ascii - no joiners or unicode
return [split $string {}]
}
package require tk
set i 0
set graphemes [list]
while {$i < [tcl::string::length $string]} {
set aftercluster [tk::endOfCluster $string $i]
lappend graphemes [string range $string $i $aftercluster-1]
set i $aftercluster
}
return $graphemes
}
proc wcswidth_clustered {string} {
package require tk
set width 0
set i 0
if {![regexp "\[\uFF-\U10FFFF\]" $string]} {
return [punk::char::wcswidth_unclustered $string] ;#still use our wcswidth to account for non-printable ascii
}
while {$i < [tcl::string::length $string]} {
set aftercluster [tk::endOfCluster $string $i]
set g [string range $string $i $aftercluster-1]
if {$aftercluster > ($i + 1)} {
#review - proper way to determine screen width (columns occupied) of a cluster??
#according to this:
#https://lib.rs/crates/unicode-display-width
#for each grapheme - if any of the code points in the cluster have an east asian width of 2,
#The entire grapheme width is 2 regardless of how many code points constitute the grapheme
set gw 1
foreach ch [split $g ""] {
if {[punk::char::wcswidth_single $ch] == 2} {
set gw 2
break
}
}
incr width $gw
#if {[string first \u200d $g] >=0} {
# incr width 2
#} else {
# #other joiners???
# incr width [wcswidth_unclustered $g]
#}
} else {
incr width [wcswidth_unclustered $g]
}
set i $aftercluster
}
return $width
}
proc wcswidth_single {char} {
scan $c %c dec
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
return 1
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
return [textutil::wcswidth_char $c]
#may return -1 - REVIEW
}
return 0
}
proc wcswidth_unclustered1 {string} {
set width 0
foreach c [split $string {}] {
scan $c %c dec
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
return $width
}
#todo - consider disallowing/erroring out when \r \n in string?
# - tab/vtab?
# - compare with wcswidth returning -1 for entire string containing such in python,perl
proc wcswidth_unclustered {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?)
#Tcl initial evaluation stack size is 2000 (? review)
#we can only split the string at arbitrary points like this because we are specifically dealing with input that has no clusters!.
set chunksize 2000
set chunks_required [expr {int(ceil([tcl::string::length $string] / double($chunksize)))}]
set width 0
set startidx 0
set endidx [expr {$startidx + $chunksize -1}]
for {set i 0} {$i < $chunks_required} {incr i} {
set chunk [tcl::string::range $string $startidx $endidx]
set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]]
foreach c $codes {
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
incr startidx $chunksize
incr endidx $chunksize
}
return $width
}
# ------------------------------------------------------------------------------------------------------
proc wcswidth0 {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+
#TODO
@ -1943,20 +2163,6 @@ tcl::namespace::eval punk::char {
}
return $width
}
#faster than textutil::wcswidth (at least for string up to a few K in length)
proc wcswidth1 {string} {
set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]]
set width 0
foreach c $codes {
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
return $width
}
proc wcswidth2 {string} {
set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]]
set widths [lmap c $codes {textutil::wcswidth_char $c}]

1
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm

@ -875,6 +875,7 @@ namespace eval punk::console {
}
}
punk::args::set_alias punk::console::code_a+ punk::ansi::a+
proc code_a+ {args} {
variable ansi_wanted
if {$ansi_wanted <= 0} {

56
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm

@ -962,21 +962,6 @@ namespace eval punk::lib {
namespace import ::punk::args::lib::tstr
#get info about punk nestindex key ie type: list,dict,undetermined
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
}
proc invoke command {
@ -1127,17 +1112,35 @@ namespace eval punk::lib {
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
-keysorttype -default "none" -choices {none dictionary ascii integer real}
-keysortdirection -default increasing -choices {increasing decreasing}
-debug -default 0 -type boolean -help\
"When enabled, produces some rudimentary debug output on stderr"
*values -min 1 -max -1
dictvalue -type list -help "dict or list value"
patterns -default "*" -type string -multiple 1 -help "key or key glob pattern"
}] $args]
#for punk::lib - we want to reduce pkg dependencies.
# - so we won't even use the tcllib debug pkg here
set opt_debug [dict get $argd opts -debug]
if {$opt_debug} {
if {[info body debug::showdict] eq ""} {
proc ::punk::lib::debug::showdict {args} {
catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"}
}
}
} else {
if {[info body debug::showdict] ne ""} {
proc ::punk::lib::debug::showdict {args} {}
}
}
set opt_sep [dict get $argd opts -separator]
set opt_mismatch_sep [dict get $argd opts -separator_mismatch]
set opt_keysorttype [dict get $argd opts -keysorttype]
set opt_keysortdirection [dict get $argd opts -keysortdirection]
set opt_trimright [dict get $argd opts -trimright]
set opt_keytemplates [dict get $argd opts -keytemplates]
puts stderr "---> $opt_keytemplates <---"
debug::showdict "keytemplates ---> $opt_keytemplates <---"
set opt_ansibase_keys [dict get $argd opts -ansibase_keys]
set opt_ansibase_values [dict get $argd opts -ansibase_values]
set opt_return [dict get $argd opts -return]
@ -4112,10 +4115,31 @@ tcl::namespace::eval punk::lib::system {
return $incomplete
}
#get info about punk nestindex key ie type: list,dict,undetermined
# pdict devel
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
#???
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
}
tcl::namespace::eval punk::lib::debug {
proc showdict {args} {}
}
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace

22
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm

@ -1896,6 +1896,10 @@ tcl::namespace::eval punk::ns {
*id punk::ns::arginfo
*proc -name punk::ns::arginfo -help\
"Show usage info for a command"
-return -type string -default table -choices {string table tableobject}
-- -type none -help\
"End of options marker
Use this if the command to view begins with a -"
*values -min 1
commandpath -help\
"command (may be alias or ensemble)"
@ -2050,7 +2054,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$origin new"]
return [punk::args::usage {*}$opts "$origin new"]
}
create {
set constructorinfo [info class constructor $origin]
@ -2079,7 +2083,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$origin create"]
return [punk::args::usage {*}$opts "$origin create"]
}
destroy {
#review - generally no doc
@ -2092,7 +2096,7 @@ tcl::namespace::eval punk::ns {
*values -min 0 -max 0
}]
punk::args::definition $argspec
return [punk::args::usage "$origin destroy"]
return [punk::args::usage {*}$opts "$origin destroy"]
}
default {
#use info object call <obj> <method> to resolve callchain
@ -2112,7 +2116,7 @@ tcl::namespace::eval punk::ns {
set id "[string trimleft $origin :] $c1" ;# "<object> <method>"
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set def [::info object definition $origin $c1]
@ -2120,7 +2124,7 @@ tcl::namespace::eval punk::ns {
set id "[string trimleft $location :] $c1" ;# "<class> <method>"
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set def [::info class definition $location $c1]
@ -2162,7 +2166,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$location $c1"]
return [punk::args::usage {*}$opts "$location $c1"]
} else {
return "unable to resolve $origin method $c1"
}
@ -2216,7 +2220,7 @@ tcl::namespace::eval punk::ns {
}]
append argspec \n $vline
punk::args::definition $argspec
return [punk::args::usage $origin]
return [punk::args::usage {*}$opts $origin]
}
privateObject {
return "Command is a privateObject - no info currently available"
@ -2327,7 +2331,7 @@ tcl::namespace::eval punk::ns {
}]
append argspec \n $vline
punk::args::definition $argspec
return [punk::args::usage $origin]
return [punk::args::usage {*}$opts $origin]
}
#check for tepam help
@ -2363,7 +2367,7 @@ tcl::namespace::eval punk::ns {
set id [string trimleft $origin :]
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set origin_ns [nsprefix $origin]

2
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm

@ -190,7 +190,7 @@ tcl::namespace::eval punk::repl::codethread {
if {[llength $::codeinterp::run_command_cache] > 2000} {
set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache]
}
if {[string first ":::" $::punk::ns::ns_current]} {
if {[string first ":::" $::punk::ns::ns_current] >= 0} {
#support for browsing 'odd' (inadvisable) namespaces
#don't use 'namespace exists' - will conflate ::test::x with ::test:::x
#if {$::punk::ns::ns_current in [namespace children [punk::ns::nsprefix $::punk::ns::ns_current]} {

225
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm

@ -299,6 +299,9 @@ tcl::namespace::eval textblock {
#It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp.
#e.g $t configure -framemap_body [table_edge_map " "]
# -- --- --- --- ---
#unused?
proc table_edge_map {char} {
variable table_edge_parts
set map [list]
@ -335,6 +338,7 @@ tcl::namespace::eval textblock {
}
return $map
}
# -- --- --- --- ---
if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} {
#*** !doctools
@ -374,6 +378,7 @@ tcl::namespace::eval textblock {
variable o_columndefs
variable o_columndata
variable o_columnstates
variable o_headerdefs
variable o_headerstates
variable o_rowdefs
@ -432,6 +437,7 @@ tcl::namespace::eval textblock {
set o_columndefs [tcl::dict::create]
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_headerdefs [tcl::dict::create] ;#by header-row
set o_headerstates [tcl::dict::create]
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
@ -439,12 +445,14 @@ tcl::namespace::eval textblock {
set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices.
set o_calculated_column_widths [list]
set o_column_width_algorithm "span"
set header_defaults [tcl::dict::create\
set o_opts_header_defaults [tcl::dict::create\
-colspans {}\
-values {}\
-ansibase {}\
-ansireset "\x1b\[m"\
-minheight 1\
-maxheight ""\
]
set o_opts_header_defaults $header_defaults
}
method width_algorithm {{alg ""}} {
@ -1107,10 +1115,18 @@ tcl::namespace::eval textblock {
}
}
}
#args checked - ok to update headerstates and columndefs and columnstates
#args checked - ok to update headerstates, headerdefs and columndefs and columnstates
tcl::dict::set o_columndefs $cidx $checked_opts
set o_headerstates $hstates
dict for {hidx hstate} $hstates {
#configure_header
if {![dict exists $o_headerdefs $hidx]} {
#remove calculated members -values -colspans
set hdefaults [dict remove $o_opts_header_defaults -values -colspans]
dict set o_headerdefs $hidx $hdefaults
}
}
tcl::dict::set o_columnstates $cidx $colstate
if {$args_got_headers} {
@ -1267,11 +1283,10 @@ tcl::namespace::eval textblock {
return $hcolspans
}
#should be configure_headerrow ?
method configure_header {index_expression args} {
#*** !doctools
#[call class::table [method configure_header]]
#[para] - undocumented
#[para] - configure header row-wise
#the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs.
#It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis
@ -1279,7 +1294,7 @@ tcl::namespace::eval textblock {
set num_headers [my header_count_calc]
set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression]
if {$hidx eq ""} {
error "textblock::table::configure_header - no row defined at index '$hidx'."
error "textblock::table::configure_header - no header row defined at index '$index_expression'."
}
if {$hidx > $num_headers -1} {
#assert - shouldn't happen
@ -1298,6 +1313,14 @@ tcl::namespace::eval textblock {
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
}
tcl::dict::set result -values $header_row_items
#review - ensure always a headerdef record for each header?
if {[tcl::dict::exists $o_headerdefs $hidx]} {
set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]]
} else {
#warn for now
puts stderr "no headerdef record for header $hidx"
}
return $result
}
if {[llength $args] == 1} {
@ -1328,7 +1351,8 @@ tcl::namespace::eval textblock {
set colspans_by_header [my header_colspans]
set result [tcl::dict::create]
set val [tcl::dict::get $colspans_by_header $hidx]
set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"]
#ansireset not required
set returndict [tcl::dict::create option $k value $val]
}
-ansibase {
set val ???
@ -1369,8 +1393,7 @@ tcl::namespace::eval textblock {
lappend header_ansibase_items $code
}
}
set header_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items]
error "sorry - -ansibase not yet implemented for header rows"
set header_ansibase [punk::ansi::codetype::sgr_merge_singles $header_ansibase_items]
lappend checked_opts $k $header_ansibase
}
-ansireset {
@ -1472,6 +1495,10 @@ tcl::namespace::eval textblock {
#safe jumptable test
#dict for {k v} $checked_opts {}
#foreach {k v} $checked_opts {}
# headerdefs excludes -values and -colspans
set update_hdefs [tcl::dict::get $o_headerdefs $hidx]
tcl::dict::for {k v} $checked_opts {
switch -- $k {
-values {
@ -1538,8 +1565,28 @@ tcl::namespace::eval textblock {
incr c
}
}
default {
dict set update_hdefs $k $v
}
}
}
set opt_minh [tcl::dict::get $update_hdefs -minheight]
set opt_maxh [tcl::dict::get $update_hdefs -maxheight]
#todo - allow zero values to hide/collapse
# - see also configure_row
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
}
#set o_headerstate $hidx -minheight? -maxheight? ???
tcl::dict::set o_headerdefs $hidx $update_hdefs
}
method add_row {valuelist args} {
@ -2050,7 +2097,8 @@ tcl::namespace::eval textblock {
foreach header $header_list {
set headerspans [tcl::dict::get $all_colspans $hrow]
set this_span [lindex $headerspans $cidx]
set hval $ansibase_header$header ;#no reset
#set hval $ansibase_header$header ;#no reset
set hval $header
set rowh [my header_height $hrow]
if {$hrow == 0} {
@ -2317,7 +2365,7 @@ tcl::namespace::eval textblock {
set h_lines [lrepeat $rowh $bline]
set hcell_blank [::join $h_lines \n]
# -usecache 1 ok
#frame borders will never display - so use the simplest frametype and don't apply any ansi
#frame borders will never display - so use the simplest frametype and don't apply any ansi
#puts "===>zerospan hlims: $hlims"
set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\
-boxlimits $hlims -boxmap $framesub_map $hcell_blank\
@ -2589,8 +2637,8 @@ tcl::namespace::eval textblock {
}
}
set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body]
set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header]
#set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body]
#set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header]
#set header_underlay $ansibase_header$cell_line_blank
@ -2613,7 +2661,35 @@ tcl::namespace::eval textblock {
set showing_vseps [my Showing_vseps]
for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} {
set hdr [lindex $headerlist $hrow]
set header_maxdataheight [my header_height $hrow] ;#from cached headerstates
#jjj
set header_maxdataheight [tcl::dict::get $o_headerstates $hrow maxheightseen]
#set header_maxdataheight [my header_height $hrow] ;#from cached headerstates
set headerdefminh [tcl::dict::get $o_headerdefs $hrow -minheight]
set headerdefmaxh [tcl::dict::get $o_headerdefs $hrow -maxheight]
if {"$headerdefminh$headerdefmaxh" ne "" && $headerdefminh eq $headerdefmaxh} {
set headerh $headerdefminh ;#exact height defined for the row
} else {
if {$headerdefminh eq ""} {
if {$headerdefmaxh eq ""} {
#both defs empty
set headerh $header_maxdataheight
} else {
set headerh [expr {min(1,$headerdefmaxh,$header_maxdataheight)}]
}
} else {
if {$headerdefmaxh eq ""} {
set headerh [expr {max($headerdefminh,$header_maxdataheight)}]
} else {
if {$header_maxdataheight < $headerdefminh} {
set headerh $headerdefminh
} else {
set headerh [expr {max($headerdefminh,$header_maxdataheight)}]
}
}
}
}
set headerrow_colspans [tcl::dict::get $all_colspans $hrow]
set this_span [lindex $headerrow_colspans $cidx]
@ -2654,8 +2730,7 @@ tcl::namespace::eval textblock {
set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight]
set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight]
if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} {
#an exact height is defined for the row
set rowh $rowdefminh
set rowh $rowdefminh ;#an exact height is defined for the row
} else {
if {$rowdefminh eq ""} {
if {$rowdefmaxh eq ""} {
@ -2814,6 +2889,7 @@ tcl::namespace::eval textblock {
$t destroy
}
puts stdout "columnstates: $o_columnstates"
puts stdout "headerdefs: $o_headerdefs"
puts stdout "headerstates: $o_headerstates"
tcl::dict::for {k coldef} $o_columndefs {
if {[tcl::dict::exists $o_columndata $k]} {
@ -4205,6 +4281,68 @@ tcl::namespace::eval textblock {
return $t
}
proc bookend_lines {block start {end "\x1b\[m"}} {
set out ""
foreach ln [split $block \n] {
append out $start $ln $end \n
}
return [string range $out 0 end-1]
}
proc ansibase_lines {block {newprefix ""}} {
set base ""
set out ""
if {$newprefix eq ""} {
foreach ln [split $block \n] {
set parts [punk::ansi::ta::split_codes $ln]
if {[lindex $parts 0] eq ""} {
if {[lindex $parts 1] ne "" && ![punk::ansi::codetype::is_sgr_reset [lindex $parts 1]]} {
set base [lindex $parts 1]
append out $base
} else {
append out $base
}
} else {
#leading plaintext - maintain our base
append out $base [lindex $parts 0] [lindex $parts 1]
}
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]
}
incr code_idx 2
}
append out {*}[lrange $parts 2 end] \n
}
return [string range $out 0 end-1]
} else {
set base $newprefix
foreach ln [split $block \n] {
set parts [punk::ansi::ta::split_codes $ln]
set code_idx 1
set offset 0
foreach {pt code} $parts {
if {$code_idx == 1} {
#first pt & code
if {$pt ne ""} {
#leading plaintext
set parts [linsert $parts 0 $base]
incr offset
}
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts [expr {$code_idx+1+$offset}] $base]
incr offset
}
incr code_idx 2
}
append out {*}$parts \n
}
return [string range $out 0 end-1]
}
}
set FRAMETYPES [textblock::frametypes]
punk::args::definition [punk::lib::tstr -return string {
*id textblock::list_as_table
@ -4606,12 +4744,22 @@ tcl::namespace::eval textblock {
return [punk::char::ansifreestring_width $tl]
}
#uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function.
proc string_length_line_max textblock {
tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
proc string_length_line_max {textblock} {
#tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
set max 0
foreach ln [split $textblock \n] {
if {[tcl::string::length $ln] > $max} {set max [tcl::string::length $ln]}
}
return $max
}
#*slightly* slower
#proc string_length_line_max {textblock} {
# tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
#}
proc string_length_line_min textblock {
tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
}
proc height {textblock} {
#This is the height as it will/would-be rendered - not the number of input lines purely in terms of le
#empty string still has height 1 (at least for left-right/right-left languages)
@ -4652,6 +4800,45 @@ tcl::namespace::eval textblock {
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size2 {textblock} {
if {$textblock eq ""} {
return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack
if {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
set lines [split $textblock \n]
set num_le [expr {[llength $lines]-1}]
#set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]]
set width 0
foreach ln $lines {
set w [::punk::char::ansifreestring_width $ln]
if {$w > $width} {
set width $w
}
}
} else {
set num_le 0
set width [punk::char::ansifreestring_width $textblock]
}
#set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list
#our concept of block-height is likely to be different to other line-counting mechanisms
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size_as_opts {textblock} {
set sz [size $textblock]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]

42
src/vendormodules/overtype-1.6.5.tm

@ -729,7 +729,7 @@ tcl::namespace::eval overtype {
-width [tcl::dict::get $vtstate renderwidth]\
-insert_mode [tcl::dict::get $vtstate insert_mode]\
-autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\
-expand_right [tcl::dict::get $opts -opt_expand_right]\
-expand_right [tcl::dict::get $opts -expand_right]\
""\
$overflow_right\
]
@ -1366,7 +1366,7 @@ tcl::namespace::eval overtype {
if {$overflowlength > 0} {
#overlay line wider or equal
#review - we still expand_right for centred for now.. possibly should expand_both with ellipsis each end?
#review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end?
set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
@ -2815,6 +2815,7 @@ tcl::namespace::eval overtype {
\x1b\[< 1006\
\x1b\[ 7CSI\
\x1bP 7DCS\
\x90 8DCS\
\x9b 8CSI\
\x1b\] 7OSC\
\x9d 8OSC\
@ -2836,6 +2837,10 @@ tcl::namespace::eval overtype {
#Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]]
}
8DCS {
#8-bit Device Control String
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
7ESC {
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
@ -3265,6 +3270,17 @@ tcl::namespace::eval overtype {
puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
T {
#CSI Pn T - SD Pan Up (empty lines introduced at top)
#CSI Pn+T - kitty extension (lines at top come from scrollback buffer)
#Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display
if {$param eq "" || $param eq "0"} {set param 1}
if {[string index $param end] eq "+"} {
puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
} else {
puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
X {
puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param"
#ECH - erase character
@ -3862,9 +3878,14 @@ tcl::namespace::eval overtype {
}
}
7DCS {
7DCS - 8DCS {
puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
#
#ST (string terminator) \x9c or \x1b\\
if {[tcl::string::index $codenorm end] eq "\x9c"} {
set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c
} else {
set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\
}
}
7OSC - 8OSC {
@ -3934,6 +3955,12 @@ tcl::namespace::eval overtype {
#tektronix cursor color
puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
99 {
#kitty desktop notifications
#https://sw.kovidgoyal.net/kitty/desktop-notifications/
#<OSC> 99 ; metadata ; payload <terminator>
puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
104 {
#reset colour palette
#we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt
@ -3942,6 +3969,13 @@ tcl::namespace::eval overtype {
set instruction [list reset_colour_palette]
break
}
1337 {
#iterm2 graphics and file transfer
puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]"
}
5113 {
puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]"
}
default {
puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}

42
src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm

@ -729,7 +729,7 @@ tcl::namespace::eval overtype {
-width [tcl::dict::get $vtstate renderwidth]\
-insert_mode [tcl::dict::get $vtstate insert_mode]\
-autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\
-expand_right [tcl::dict::get $opts -opt_expand_right]\
-expand_right [tcl::dict::get $opts -expand_right]\
""\
$overflow_right\
]
@ -1366,7 +1366,7 @@ tcl::namespace::eval overtype {
if {$overflowlength > 0} {
#overlay line wider or equal
#review - we still expand_right for centred for now.. possibly should expand_both with ellipsis each end?
#review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end?
set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
@ -2815,6 +2815,7 @@ tcl::namespace::eval overtype {
\x1b\[< 1006\
\x1b\[ 7CSI\
\x1bP 7DCS\
\x90 8DCS\
\x9b 8CSI\
\x1b\] 7OSC\
\x9d 8OSC\
@ -2836,6 +2837,10 @@ tcl::namespace::eval overtype {
#Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]]
}
8DCS {
#8-bit Device Control String
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
7ESC {
set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]]
}
@ -3265,6 +3270,17 @@ tcl::namespace::eval overtype {
puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
T {
#CSI Pn T - SD Pan Up (empty lines introduced at top)
#CSI Pn+T - kitty extension (lines at top come from scrollback buffer)
#Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display
if {$param eq "" || $param eq "0"} {set param 1}
if {[string index $param end] eq "+"} {
puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
} else {
puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
X {
puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param"
#ECH - erase character
@ -3862,9 +3878,14 @@ tcl::namespace::eval overtype {
}
}
7DCS {
7DCS - 8DCS {
puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
#
#ST (string terminator) \x9c or \x1b\\
if {[tcl::string::index $codenorm end] eq "\x9c"} {
set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c
} else {
set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\
}
}
7OSC - 8OSC {
@ -3934,6 +3955,12 @@ tcl::namespace::eval overtype {
#tektronix cursor color
puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
99 {
#kitty desktop notifications
#https://sw.kovidgoyal.net/kitty/desktop-notifications/
#<OSC> 99 ; metadata ; payload <terminator>
puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
104 {
#reset colour palette
#we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt
@ -3942,6 +3969,13 @@ tcl::namespace::eval overtype {
set instruction [list reset_colour_palette]
break
}
1337 {
#iterm2 graphics and file transfer
puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]"
}
5113 {
puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]"
}
default {
puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}

164
src/vfs/_vfscommon.vfs/modules/punk-0.1.tm

@ -101,12 +101,15 @@ set punk_testd2 [dict create \
] \
]
#impolitely cooperative withe punk repl - todo - tone it down.
#impolitely cooperative with punk repl - todo - tone it down.
#namespace eval ::punk::repl::codethread {
# variable running 0
#}
package require punk::lib
package require punk::lib ;# subdependency punk::args
package require punk::ansi
if {![llength [info commands ::ansistring]]} {
namespace import punk::ansi::ansistring
}
#require aliascore after punk::lib & punk::ansi are loaded
package require punk::aliascore ;#mostly punk::lib aliases
punk::aliascore::init
@ -114,9 +117,6 @@ punk::aliascore::init
package require punk::repl::codethread
package require punk::config
#package require textblock
if {![llength [info commands ::ansistring]]} {
namespace import punk::ansi::ansistring
}
package require punk::console
package require punk::ns
package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems
@ -862,6 +862,8 @@ namespace eval punk {
}
}
#? {
#review - compare to %# ?????
#seems to be unimplemented ?
set assigned [string length $leveldata]
set already_assigned 1
}
@ -7149,12 +7151,93 @@ namespace eval punk {
dict filter $result value {?*}
}
punk::args::definition {
*id punk::inspect
*proc -name punk::inspect -help\
"Function to display values - used pimarily in a punk pipeline.
The raw value arguments (not options) are always returned to pass
forward in the pipeline.
(pipeline data inserted at end of each |...> segment is passed as single item unless
inserted with an expanding insertion specifier such as .=>* )
e.g1:
.= list a b c |v1,/1-end,/0>\\
.=>* inspect -label i1 -- |>\\
.=v1> inspect -label i2 -- |>\\
string toupper
(3) i1: {a b c} {b c} a
(1) i2: a b c
- A B C
"
-label -type string -default "" -help\
"An optional label to help distinguish output when multiple
inspect statements are in a pipeline. This appears after the
bracketed count indicating number of values supplied.
e.g (2) MYLABEL: val1 val2
The label can include ANSI codes.
e.g
inspect -label [a+ red]mylabel -- val1 val2 val3
"
-limit -type int -default 20 -help\
"When multiple values are passed to inspect - limit the number
of elements displayed in -channel output.
When truncation has occured an elipsis indication (...) will be appended.
e.g
.= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+
(11) 20 23 26 29...
- 385
For no limit - use -limit -1
"
-channel -type string -default stderr -help\
"An existing open channel to write to. If value is any of nul, null, /dev/nul
the channel output is disabled. This effectively disables inspect as the args
are simply passed through in the return to continue the pipeline.
"
-showcount -type boolean -default 1 -help\
"Display a leading indicator in brackets showing the number of arg values present."
-ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels {
0 "Strip ANSI codes from display
of values. The disply output will
still be colourised if -ansibase has
not been set to empty string or
[a+ normal]. The stderr or stdout
channels may also have an ansi colour.
(see 'colour off' or punk::config)"
1 "Leave value as is"
2 "Display the ANSI codes and
other control characters inline
with replacement indicators.
e.g esc, newline, space, tab"
VIEW "Alias for 2"
3 "Display as per 2 but with
colourised ANSI replacement codes."
VIEWCODES "Alias for 3"
4 "Display ANSI and control
chars in default colour, but
apply the contained ansi to
the text portions so they display
as they would for -ansi 1"
VIEWSTYLE "Alias for 4"
}
-ansibase -type ansistring -default {${[a+ brightgreen]}} -help\
"Base ansi code(s) that will apply to output written to the chosen -channel.
If there are ansi resets in the displayed values - output will revert to this base.
Does not affect return value."
-- -type none -help\
"End of options marker.
It is advisable to use this, as data in a pipeline may often being with -"
*values -min 0 -max -1
arg -type string -optional 1 -multiple 1 -help\
"value to display"
}
#pipeline inspect
#e.g
#= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data}
proc inspect {args} {
set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1]
set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1 -ansibase [a+ brightgreen]]
set flags [list]
set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect --
if {$endoptsposn >= 0} {
@ -7177,24 +7260,28 @@ namespace eval punk {
}
foreach {k v} $flags {
if {$k ni [dict keys $defaults]} {
error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --"
#error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --"
punk::args::get_by_id punk::inspect $args
}
}
set opts [dict merge $defaults $flags]
# -- --- --- --- ---
set label [dict get $opts -label]
set channel [dict get $opts -channel]
set showcount [dict get $opts -showcount]
set label [dict get $opts -label]
set channel [dict get $opts -channel]
set showcount [dict get $opts -showcount]
if {[string length $label]} {
set label "${label}: "
}
set limit [dict get $opts -limit]
set opt_ansi [dict get $opts -ansi]
set opt_ansiraw [dict get $opts -ansi]
set opt_ansi [tcl::prefix::match -error "" [list 0 1 2 3 4 view viewcodes viewstyle] [string tolower $opt_ansiraw]]
switch -- [string tolower $opt_ansi] {
0 - 1 - 2 {}
view {set opt_ansi 2}
0 - 1 - 2 - 3 - 4 {}
view {set opt_ansi 2}
viewcodes {set opt_ansi 3}
viewstyle {set opt_ansi 4}
default {
error "inspect -ansi 0|1|2|view - received -ansi $opt_ansi"
error "inspect -ansi 0|1|2|view|3|viewcodes|4|viewstyle - received -ansi $opt_ansiraw"
}
}
# -- --- --- --- ---
@ -7248,15 +7335,50 @@ namespace eval punk {
} else {
set displaycount ""
}
if {$opt_ansi == 0} {
set displayval [punk::ansi::ansistrip $displayval]
} elseif {$opt_ansi == 2} {
set displayval [ansistring VIEW $displayval]
set ansibase [dict get $opts -ansibase]
if {$ansibase ne ""} {
#-ansibase default is hardcoded into punk::args definition
#run a test using any ansi code to see if colour is still enabled
if {[a+ red] eq ""} {
set ansibase "" ;#colour seems to be disabled
}
}
switch -- $opt_ansi {
0 {
set displayval $ansibase[punk::ansi::ansistrip $displayval]
}
1 {
#val may have ansi - including resets. Pass through ansibase_lines to
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
2 {
set displayval $ansibase[ansistring VIEW $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
3 {
set displayval $ansibase[ansistring VIEWCODE $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
4 {
set displayval $ansibase[ansistring VIEWSTYLE $displayval]
if {$ansibase ne ""} {
set displayval [::textblock::ansibase_lines $displayval $ansibase]
}
}
}
if {![string length $more]} {
puts $channel "$displaycount$label[a green bold]$displayval[a]"
puts $channel "$displaycount$label$displayval[a]"
} else {
puts $channel "$displaycount$label[a green bold]$displayval[a yellow bold]$more[a]"
puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]"
}
return $val
}

19
src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm

@ -167,6 +167,7 @@ tcl::namespace::eval punk::ansi::class {
}
default {
puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x"
punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args
}
}
}
@ -2415,6 +2416,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
*id punk::ansi::a+
*proc -name "punk::ansi::a+" -help\
"Returns an ANSI sgr escape sequence based on the list of supplied codes.
Unlike punk::ansi::a - it is not prefixed with an ANSI reset.
"
*values -min 0 -max -1
} [string map [list <choices> [dict keys $SGR_map]] {
@ -2432,10 +2434,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
The acceptable values for <termcolour> and <webcolour> can be queried using
punk::ansi::a? term
and
punk::ansi::a? web"
punk::ansi::a? web
Example to set foreground red and background cyan followed by a reset:
set str \"[a+ red Cyan]sample text[a]\"
"
}]]
proc a+ {args} {
#*** !doctools
#[call [fun a+] [opt {ansicode...}]]
@ -7065,13 +7069,12 @@ tcl::namespace::eval punk::ansi::ansistring {
}
}
#inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi
#todo - document
interp alias {} ansistring {} ::punk::ansi::ansistring
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}]
}
tcl::namespace::eval punk::ansi::control {
proc APC {args} {
return \x1b_[join $args {;}]\x1b\\
@ -7393,6 +7396,10 @@ tcl::namespace::eval punk::ansi::internal {
}
}
#inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi
#todo - document
interp alias {} ansistring {} ::punk::ansi::ansistring
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set NAMESPACES [list]

87
src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm

@ -353,7 +353,7 @@ tcl::namespace::eval punk::args {
}
set optionspecs [join $normargs \n]
if {[string first \$\{ $optionspecs] > 0} {
set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 $optionspecs]]
set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]]
}
} else {
if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} {
@ -1262,30 +1262,43 @@ tcl::namespace::eval punk::args {
if {$arg_error_isrunning} {
error "arg_error already running - error in arg_error?\n triggering errmsg: $msg"
}
set arg_error_isrunning 1
if {[llength $args] %2 != 0} {
error "error in arg_error processing - expected opt/val pairs after msg and spec_dict"
}
set arg_error_isrunning 1
set badarg ""
set returntype error
set returntype table ;#table as string
set as_error 1 ;#usual case is to raise an error
dict for {k v} $args {
switch -- $k {
-badarg {
set badarg $v
}
-aserror {
if {![string is boolean -strict $v]} {
set arg_error_isrunning 0
error "arg_error invalid value for option -aserror. Received '$v' expected a boolean"
}
set as_error $v
}
-return {
if {$v ni {error string}} {
error "arg_error invalid value for option -return. Received '$v' expected one of: error string"
if {$v ni {string table tableobject}} {
set arg_error_isrunning 0
error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject"
}
set returntype $v
}
default {
set arg_error_isrunning 0
error "arg_error invalid option $k. Known_options: -badarg -return"
}
}
}
set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist.
#REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error
#e.g list_as_table
@ -1300,12 +1313,20 @@ tcl::namespace::eval punk::args {
#couldn't load textblock package
#just return the original errmsg without formatting
}
set use_table 0
if {$has_textblock && $returntype in {table tableobject}} {
set use_table 1
}
set errlines [list] ;#for non-textblock output
if {[catch {
if {$has_textblock} {
if {$use_table} {
append errmsg \n
} else {
append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n
if {($returntype in {table tableobject}) && !$has_textblock} {
append errmsg \n "[a+ brightred](layout package textblock is missing)[a]" \n
} else {
append errmsg \n
}
}
set procname [Dict_getdef $spec_dict proc_info -name ""]
set prochelp [Dict_getdef $spec_dict proc_info -help ""]
@ -1333,7 +1354,7 @@ tcl::namespace::eval punk::args {
} else {
set docurl_display ""
}
if {$has_textblock} {
if {$use_table} {
set t [textblock::class::table new [a+ brightyellow]Usage[a]]
$t add_column -headers $blank_header_col -minwidth 3
$t add_column -headers $blank_header_col
@ -1343,7 +1364,7 @@ tcl::namespace::eval punk::args {
}
set h 0
if {$procname ne ""} {
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display]
} else {
lappend errlines "PROC/METHOD: $procname_display"
@ -1351,7 +1372,7 @@ tcl::namespace::eval punk::args {
incr h
}
if {$prochelp ne ""} {
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list Description: $prochelp_display]
} else {
lappend errlines "Description: $prochelp_display"
@ -1362,14 +1383,14 @@ tcl::namespace::eval punk::args {
if {![catch {package require punk::ansi}]} {
set docurl [punk::ansi::hyperlink $docurl]
}
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -colspans {1 4 0 0 0} -values [list $docname $docurl_display]
} else {
lappend errlines "$docname $docurl_display"
}
incr h
}
if {$has_textblock} {
if {$use_table} {
$t configure_header $h -values {Arg Type Default Multi Help}
} else {
lappend errlines " --ARGUMENTS-- "
@ -1519,7 +1540,7 @@ tcl::namespace::eval punk::args {
set numcols [llength $formattedchoices]
}
if {$numcols > 0} {
if {$has_textblock} {
if {$use_table} {
#risk of recursing
set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices]
append help \n[textblock::join -- " " $choicetable]
@ -1565,7 +1586,7 @@ tcl::namespace::eval punk::args {
append typeshow \n "-range [dict get $arginfo -range]"
}
if {$has_textblock} {
if {$use_table} {
$t add_row [list $argshow $typeshow $default $multiple $help]
if {$arg eq $badarg} {
$t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG
@ -1577,11 +1598,14 @@ tcl::namespace::eval punk::args {
}
}
if {$has_textblock} {
if {$use_table} {
$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow]
$t configure -maxwidth 80
$t configure -maxwidth 80 ;#review
append errmsg [$t print]
$t destroy
if {$returntype ne "tableobject"} {
#returntype of table means just the text of the table
$t destroy
}
} else {
append errmsg [join $errlines \n]
}
@ -1595,11 +1619,22 @@ tcl::namespace::eval punk::args {
}
set arg_error_isrunning 0
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
if {$returntype eq "error"} {
return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg
#Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
if {$use_table} {
#assert returntype is one of table, tableobject
set result $errmsg ;#default if for some reason table couldn't be used
if {$returntype eq "tableobject"} {
if {[info object isa object $t]} {
set result $t
}
}
} else {
return $errmsg
set result $errmsg
}
if {$as_error} {
return -code error -errorcode {TCL WRONGARGS PUNK} $result
} else {
return $result
}
}
@ -1609,17 +1644,21 @@ tcl::namespace::eval punk::args {
*proc -name punk::args::usage -help\
"return usage information as a string
in table form."
-return -default table -choices {string table tableobject}
*values -min 0 -max 1
id -help\
"exact id.
Will usually match the command name"
}]
proc usage {id} {
proc usage {args} {
lassign [dict values [punk::args::get_by_id punk::args::usage $args]] leaders opts values received
set id [dict get $values id]
set speclist [get_spec $id]
if {[llength $speclist] == 0} {
error "punk::args::usage - no such id: $id"
}
arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] -return string
arg_error "" [uplevel 1 [list punk::args::definition {*}$speclist]] {*}$opts -aserror 0
}
lappend PUNKARGS [list {
@ -2726,7 +2765,7 @@ tcl::namespace::eval punk::args::lib {
*id punk::args::lib::tstr
*proc -name punk::args::lib::tstr -help\
"A rough equivalent of js template literals"
-allowcommands -default -1 -type none -help\
-allowcommands -default 0 -type none -help\
"if -allowcommands is present, placeholder can contain commands e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}"
-return -default list -choices {dict list string args}\
-choicelabels {

65
src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm

@ -198,12 +198,58 @@ tcl::namespace::eval punk::args::tclcore {
The handler is invoked when a command called from within the namespace cannot
be found in the current namespace, the namespace's path nor in the global
namespace.
"
When the handler is invoiked, the full invocation line will be appended to
the script and the result evaluated in the context of the namespace.
The default handler for all namespaces is [a+ italic]::unknown[a].
If no argument is given, it returns the handler for the current namespace."
*values -min 0 -max 1
script -type script -optional 1 -help\
"A well formed list representing a command name and "
"A well formed list representing a command name and optional arguments."
} "*doc -name Manpage: -url [manpage_tcl namespace]" ]
set I [a+ italic]
set NI [a+ noitalic]
lappend PUNKARGS [list {
*id tcl::process::status
*proc -name "Builtin: tcl::process::status" -help\
"Returns a dictionary mapping subprocess PIDs to their respective status.
if ${$I}pids${$NI} is specified as a list of PIDs then the command
only returns the status of the matching subprocesses if they exist, and
raises an error otherwise.
For active processes, the status is an empty value. For terminated
processes, the status is a list with the following format:
{code ?msg errorCode?}
where:
${$I}code${$NI}
is a standard Tcl return code, ie.,
0 for TCL_OK and 1 for TCL_ERROR,
${$I}msg${$NI}
is the human readable error message,
${$I}errorCode${$NI}
uses the same format as the errorCode global variable
Note that msg and errorCode are only present for abnormally
terminated processes (i.e. those where the code is nonzero).
Under the hood this command calls Tcl_WaitPid with the
WNOHANG flag set for non-blocking behaviour, unless the -wait
switch is set (see below).
"
-wait -type none -optional 1 -help\
"By default the command returns immediately (the underlying Tcl_WaitPid
is called with the WNOHANG flag set) unless this switch is set. if pids
is specified as a list of PIDS then the command waits until the status
of the matching subprocesses are avaliable. If pids was not specified,
this command will wait for all known subprocesses."
-- -type none -optional 1 -help\
"Marks the end of switches. The argument following this one will be
treated as the first arg even if it starts with a -."
*values -min 0 -max 1
pids -type list -optional 1 -help\
"A list of PIDs"
} "*doc -name Manpage: -url [manpage_tcl namespace]" ]
lappend PUNKARGS [list {
*id lappend
*proc -name "builtin: lappend" -help\
@ -613,13 +659,6 @@ tcl::namespace::eval punk::args::tclcore {
string -type string -optional 0
}] "*doc -name Manpage: -url [manpage_tcl string]"
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
}
}
lappend ::punk::args::register::NAMESPACES ::punk::args::tclcore
#*** !doctools
#[subsection {Namespace punk::args::tclcore}]
#[para] Core API functions for punk::args::tclcore
@ -687,6 +726,14 @@ tcl::namespace::eval punk::args::tclcore::lib {
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace
}
}
lappend ::punk::args::register::NAMESPACES ::punk::args::tclcore
## Ready
package provide punk::args::tclcore [tcl::namespace::eval punk::args::tclcore {
variable pkg punk::args::tclcore

248
src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm

@ -600,6 +600,48 @@ tcl::namespace::eval punk::char {
puts stdout \n
puts stdout "cursor position immediately after outputing 3 bytes (xyz): $cursorposn"
}
proc test_zalgo {} {
#from: https://github.com/jameslanska/unicode-display-width/blob/5e28d94c75e8c421a87199363b85c90dc37125b8/docs/unicode_background.md
#see: https://lingojam.com/ZalgoText
puts stdout "44 chars long - 9 graphemes - 9 columns wide"
set str "Ẓ̌á̲l͔̝̞̄̑͌g̖̘̘̔̔͢͞͝o̪̔T̢̙̫̈̍͞e̬͈͕͌̏͑x̺̍̓̓ͅ"
}
proc test_zalgo2 {} {
# ------------------------
set str "Z̸̢͉̣͔̭̪͙̖̳̘͈͍̤̩̟͈͈͕̯̅̏̆̓̌́́͌̿̕ͅą̷̦̤̫̩͕̥̐̎̓́́̂̀͆́̔̄̈́̏̌́̆͜͜͝͠l̴̩̙̺͚̟͇͖͔͕̹̟͌̈́̄̇́̉̋̕̚͜͠͠g̸͇̩͔̺̝̗̥̖̙̑̈́̈́̿̾̌͌͊̈̀͊̑̇̑͌̍̅̌͊͜͠͝ǫ̴̢̧͎͔̞̤̻̱̮̬͕̗̭͍̣̠̳̆̀̋̓͒̾̄͜͝͠͝T̴̛͉̬̋́̈́̈́̓͗̍̏̔̈̋̀͐̓̎̅̚̕͠͝͝ê̵̖̖̈͊̔̓̔̐̓̃͊̋͋̎͂͋̕x̴̡͎͖̼͎̦͎̲̪̘̺̯̲̬̮̥̼̰͌̃͜ͅt̶̛̘͎̰̔͐͌́̈́͊͗͌̅͂̐̆͌̀͂͘"
# ------------------------
}
proc test_zalgo3 {} {
# ------------------------
set str "Ẕ̸̢̼̺̜̰̣̣̖̭̜͓͖̺̥̼̠͙͙̟̥̟̠̤̫͍̠̤̮͚̝̜̙͈̦̙̩̹̙̜̩̦͔͕̈̃̅̇̈́͂̇̽̈́́́́̎͊̂̑̋͆̔̾͋̚͜ͅã̵̛̪̽̎̃͑̒̇͋͂̽̃̍͊̀̈̊̊̔̊̆̈́͗͑͗̽̄̋͗̄͌̑͊͝͝͠ͅl̵̢͇̖͉͖̝̹̜̞͓͎͍͈̞̱̙͙̦̪͔̱̮͈͉̼͎̭̝̯͇͚̺̟̱͙̳̰̙͚͖̝̫͙̎̅̃͆̈́̋̌̔̋̋͗̈́̔̐͆̈́̓̾̄̀́̏́͒̆̌͒̈́̈́̾̏̀͜͝g̸̖͂͋̊͗̈́̓̆̈̋̒͐̕o̶̧̢͓̲̗̠̘͕̦̤̹̗͉̰͔̯͓̭̹̻͔͇̯̜̙̍̂̃̃̀̓͌̒͊̊̋̒̿̿̌͐̄͗̾̕͝T̶̛̳̜̰͍̹̻̫̠̱̼̼̙̆̑̾̾͛́́̿͋͌̎̀̀̽̆͌̽̂̈̇̅̇̃́̿͗̾͒̎͊̑̾͝͠ȩ̸̢̨̛̛̛̭͔͎͇̫͎͈̲̻̙͕͎̣͈̩̺̗͖͙͇͌͐̒̎͐̓́̉́͐̓̐͌̅̊͋͑̈́͗͑̏̕͜͜͝ͅx̸̧̧̛̖̣̥̘͎͎̳̭̙̦̝͖̝̮̱̹̯̺̙̩̯̮͖̻̰͓̰̩͇̥̑͌̊̐̉̏͆̓̑̎̊̓͒̂̄̆͆̀̊̄̈̽͐͛̏͊̓̌͑́̎̈́̍̈́̊͗̉̋͆̿̊͘͜͜͝͝ͅͅͅt̵̡̨̜̘͎̦͚̠̗̺͉̼̠̲̠͙̺̹̗̲̏̈́̂̚͜͜͝ͅ"
# ------------------------
}
proc test_farmer {} {
#an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals
#(similar to the problem with grave accent rendering width that the test_grave proc is written for)
@ -620,17 +662,29 @@ tcl::namespace::eval punk::char {
puts stdout "farmer2 with no joiner codes: \\U0001f9d1\\U001f33e : $farmer2"
package require punk::console
puts stdout \n
puts stdout "#2--5---9---C---"
puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1
puts -nonewline "${farmer1}";set cursorposn [punk::console::get_cursor_pos]
puts stdout \n
puts stdout "cursor position immediately after outputing farmer1 (expecting 1 glyph 2 wide) : $cursorposn"
puts -nonewline "${farmer1}";set cursorposn [punk::console::get_cursor_pos_list]
puts stdout "\ncursor position immediately after outputing farmer1 (expecting 1 glyph 2 wide) : cursor at col [lindex $cursorposn 1]"
if {[lindex $cursorposn 1] eq "3"} {
puts stdout "[a+ green]OK[a]"
} else {
puts stdout "[a+ red]ERR - expected cursor position to be 3 after emitting farmer1[a]"
}
puts stdout "----------------"
puts stdout "#2--5---9---C---"
puts -nonewline "${farmer2}";set cursorposn [punk::console::get_cursor_pos]
puts stdout \n
puts stdout "cursor position immediately after outputing farmer2 (expecting 2 glyphs 4 wide in total): $cursorposn"
puts -nonewline "${farmer2}";set cursorposn [punk::console::get_cursor_pos_list]
puts stdout "\ncursor position immediately after outputing farmer2 (expecting 2 glyphs 4 wide in total): cursor at col [lindex $cursorposn 1]"
if {[lindex $cursorposn 1] eq "5"} {
puts stdout "[a+ green]OK[a]"
} else {
puts stdout "[a+ red]ERR - expected cursor position to be 5 after emitting farmer2[a]"
}
puts stdout "----------------"
return [list $farmer1 $farmer2]
puts "returning farmer1 - should be single glyph"
return $farmer1
}
#G0 Sets Sequence G1 Sets Sequence Meaning
@ -1916,6 +1970,172 @@ tcl::namespace::eval punk::char {
# - tab/vtab?
# - compare with wcswidth returning -1 for entire string containing such in python,perl
proc wcswidth {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?)
#Tcl initial evaluation stack size is 2000 (? review)
#REVIEW - when we cater for grapheme clusters - we can't just split the string at arbitrary points like this!!
set chunksize 2000
set chunks_required [expr {int(ceil([tcl::string::length $string] / double($chunksize)))}]
set width 0
set startidx 0
set endidx [expr {$startidx + $chunksize -1}]
for {set i 0} {$i < $chunks_required} {incr i} {
set chunk [tcl::string::range $string $startidx $endidx]
set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]]
foreach c $codes {
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
incr startidx $chunksize
incr endidx $chunksize
}
return $width
}
# ------------------------------------------------------------------------------------------------------
#test
# ------------------------------------------------------------------------------------------------------
proc grapheme_split_tk {string} {
if {![regexp "\[\uFF-\U10FFFF\]" $string]} {
#only ascii - no joiners or unicode
return [split $string {}]
}
package require tk
set i 0
set graphemes [list]
while {$i < [tcl::string::length $string]} {
set aftercluster [tk::endOfCluster $string $i]
lappend graphemes [string range $string $i $aftercluster-1]
set i $aftercluster
}
return $graphemes
}
proc wcswidth_clustered {string} {
package require tk
set width 0
set i 0
if {![regexp "\[\uFF-\U10FFFF\]" $string]} {
return [punk::char::wcswidth_unclustered $string] ;#still use our wcswidth to account for non-printable ascii
}
while {$i < [tcl::string::length $string]} {
set aftercluster [tk::endOfCluster $string $i]
set g [string range $string $i $aftercluster-1]
if {$aftercluster > ($i + 1)} {
#review - proper way to determine screen width (columns occupied) of a cluster??
#according to this:
#https://lib.rs/crates/unicode-display-width
#for each grapheme - if any of the code points in the cluster have an east asian width of 2,
#The entire grapheme width is 2 regardless of how many code points constitute the grapheme
set gw 1
foreach ch [split $g ""] {
if {[punk::char::wcswidth_single $ch] == 2} {
set gw 2
break
}
}
incr width $gw
#if {[string first \u200d $g] >=0} {
# incr width 2
#} else {
# #other joiners???
# incr width [wcswidth_unclustered $g]
#}
} else {
incr width [wcswidth_unclustered $g]
}
set i $aftercluster
}
return $width
}
proc wcswidth_single {char} {
scan $c %c dec
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
return 1
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
return [textutil::wcswidth_char $c]
#may return -1 - REVIEW
}
return 0
}
proc wcswidth_unclustered1 {string} {
set width 0
foreach c [split $string {}] {
scan $c %c dec
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
return $width
}
#todo - consider disallowing/erroring out when \r \n in string?
# - tab/vtab?
# - compare with wcswidth returning -1 for entire string containing such in python,perl
proc wcswidth_unclustered {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?)
#Tcl initial evaluation stack size is 2000 (? review)
#we can only split the string at arbitrary points like this because we are specifically dealing with input that has no clusters!.
set chunksize 2000
set chunks_required [expr {int(ceil([tcl::string::length $string] / double($chunksize)))}]
set width 0
set startidx 0
set endidx [expr {$startidx + $chunksize -1}]
for {set i 0} {$i < $chunks_required} {incr i} {
set chunk [tcl::string::range $string $startidx $endidx]
set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]]
foreach c $codes {
if {$c <= 255 && !($c < 31 || $c == 127)} {
#review - non-printing ascii? why does textutil::wcswidth report 1 ??
#todo - compare with python or other lang wcwidth
incr width
} elseif {$c < 917504 || $c > 917631} {
#TODO - various other joiners and non-printing chars
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
}
incr startidx $chunksize
incr endidx $chunksize
}
return $width
}
# ------------------------------------------------------------------------------------------------------
proc wcswidth0 {string} {
#faster than textutil::wcswidth (at least for string up to a few K in length)
#..but - 'scan' is horrible for 400K+
#TODO
@ -1943,20 +2163,6 @@ tcl::namespace::eval punk::char {
}
return $width
}
#faster than textutil::wcswidth (at least for string up to a few K in length)
proc wcswidth1 {string} {
set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]]
set width 0
foreach c $codes {
set w [textutil::wcswidth_char $c]
if {$w < 0} {
return -1
} else {
incr width $w
}
}
return $width
}
proc wcswidth2 {string} {
set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]]
set widths [lmap c $codes {textutil::wcswidth_char $c}]

1
src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm

@ -875,6 +875,7 @@ namespace eval punk::console {
}
}
punk::args::set_alias punk::console::code_a+ punk::ansi::a+
proc code_a+ {args} {
variable ansi_wanted
if {$ansi_wanted <= 0} {

56
src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm

@ -962,21 +962,6 @@ namespace eval punk::lib {
namespace import ::punk::args::lib::tstr
#get info about punk nestindex key ie type: list,dict,undetermined
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
}
proc invoke command {
@ -1127,17 +1112,35 @@ namespace eval punk::lib {
-keytemplates -default {\$\{$key\}} -type list -help "list of templates for keys at each level"
-keysorttype -default "none" -choices {none dictionary ascii integer real}
-keysortdirection -default increasing -choices {increasing decreasing}
-debug -default 0 -type boolean -help\
"When enabled, produces some rudimentary debug output on stderr"
*values -min 1 -max -1
dictvalue -type list -help "dict or list value"
patterns -default "*" -type string -multiple 1 -help "key or key glob pattern"
}] $args]
#for punk::lib - we want to reduce pkg dependencies.
# - so we won't even use the tcllib debug pkg here
set opt_debug [dict get $argd opts -debug]
if {$opt_debug} {
if {[info body debug::showdict] eq ""} {
proc ::punk::lib::debug::showdict {args} {
catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"}
}
}
} else {
if {[info body debug::showdict] ne ""} {
proc ::punk::lib::debug::showdict {args} {}
}
}
set opt_sep [dict get $argd opts -separator]
set opt_mismatch_sep [dict get $argd opts -separator_mismatch]
set opt_keysorttype [dict get $argd opts -keysorttype]
set opt_keysortdirection [dict get $argd opts -keysortdirection]
set opt_trimright [dict get $argd opts -trimright]
set opt_keytemplates [dict get $argd opts -keytemplates]
puts stderr "---> $opt_keytemplates <---"
debug::showdict "keytemplates ---> $opt_keytemplates <---"
set opt_ansibase_keys [dict get $argd opts -ansibase_keys]
set opt_ansibase_values [dict get $argd opts -ansibase_values]
set opt_return [dict get $argd opts -return]
@ -4112,10 +4115,31 @@ tcl::namespace::eval punk::lib::system {
return $incomplete
}
#get info about punk nestindex key ie type: list,dict,undetermined
# pdict devel
proc nestindex_info {args} {
set argd [punk::args::get_dict {
-parent -default ""
nestindex
} $args]
set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} {
set parent_type undetermined
} else {
set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing
}
#???
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
}
tcl::namespace::eval punk::lib::debug {
proc showdict {args} {}
}
if {![info exists ::punk::args::register::NAMESPACES]} {
namespace eval ::punk::args::register {
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace

22
src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm

@ -1896,6 +1896,10 @@ tcl::namespace::eval punk::ns {
*id punk::ns::arginfo
*proc -name punk::ns::arginfo -help\
"Show usage info for a command"
-return -type string -default table -choices {string table tableobject}
-- -type none -help\
"End of options marker
Use this if the command to view begins with a -"
*values -min 1
commandpath -help\
"command (may be alias or ensemble)"
@ -2050,7 +2054,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$origin new"]
return [punk::args::usage {*}$opts "$origin new"]
}
create {
set constructorinfo [info class constructor $origin]
@ -2079,7 +2083,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$origin create"]
return [punk::args::usage {*}$opts "$origin create"]
}
destroy {
#review - generally no doc
@ -2092,7 +2096,7 @@ tcl::namespace::eval punk::ns {
*values -min 0 -max 0
}]
punk::args::definition $argspec
return [punk::args::usage "$origin destroy"]
return [punk::args::usage {*}$opts "$origin destroy"]
}
default {
#use info object call <obj> <method> to resolve callchain
@ -2112,7 +2116,7 @@ tcl::namespace::eval punk::ns {
set id "[string trimleft $origin :] $c1" ;# "<object> <method>"
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set def [::info object definition $origin $c1]
@ -2120,7 +2124,7 @@ tcl::namespace::eval punk::ns {
set id "[string trimleft $location :] $c1" ;# "<class> <method>"
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set def [::info class definition $location $c1]
@ -2162,7 +2166,7 @@ tcl::namespace::eval punk::ns {
incr i
}
punk::args::definition $argspec
return [punk::args::usage "$location $c1"]
return [punk::args::usage {*}$opts "$location $c1"]
} else {
return "unable to resolve $origin method $c1"
}
@ -2216,7 +2220,7 @@ tcl::namespace::eval punk::ns {
}]
append argspec \n $vline
punk::args::definition $argspec
return [punk::args::usage $origin]
return [punk::args::usage {*}$opts $origin]
}
privateObject {
return "Command is a privateObject - no info currently available"
@ -2327,7 +2331,7 @@ tcl::namespace::eval punk::ns {
}]
append argspec \n $vline
punk::args::definition $argspec
return [punk::args::usage $origin]
return [punk::args::usage {*}$opts $origin]
}
#check for tepam help
@ -2363,7 +2367,7 @@ tcl::namespace::eval punk::ns {
set id [string trimleft $origin :]
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} {
return [uplevel 1 [list punk::args::usage $id]]
return [uplevel 1 [list punk::args::usage {*}$opts $id]]
}
}
set origin_ns [nsprefix $origin]

17
src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm

@ -2584,7 +2584,8 @@ namespace eval repl {
set codethread_cond [thread::cond create] ;#repl::codethread_cond held by parent(repl) vs punk::repl::codethread::replthread_cond held by child(codethread)
set codethread_mutex [thread::mutex create]
thread::send $codethread [string map [list %args% [list $opts]\
set init_script [string map [list %args% [list $opts]\
%argv0% [list $::argv0]\
%argv% [list $::argv]\
%argc% [list $::argc]\
@ -3097,8 +3098,20 @@ namespace eval repl {
#puts stderr "returning threadid"
#puts stderr [thread::id]
return [thread::id]
thread::id
}]
#thread::send $codethread $init_script
if {![catch {
thread::send $codethread $init_script result ;#use a result var when wrapping in a catch - without it we can get a return code of 2 (TCL_RETURN)
} errMsg]} {
return $result
} else {
puts stderr "repl::init Failed during thread::send"
puts stderr "$::errorInfo"
thread::release $codethread
error $errMsg
}
}
#init - don't auto init - require init with possible options e.g -safe
}

2
src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm

@ -190,7 +190,7 @@ tcl::namespace::eval punk::repl::codethread {
if {[llength $::codeinterp::run_command_cache] > 2000} {
set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache]
}
if {[string first ":::" $::punk::ns::ns_current]} {
if {[string first ":::" $::punk::ns::ns_current] >= 0} {
#support for browsing 'odd' (inadvisable) namespaces
#don't use 'namespace exists' - will conflate ::test::x with ::test:::x
#if {$::punk::ns::ns_current in [namespace children [punk::ns::nsprefix $::punk::ns::ns_current]} {

225
src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm

@ -299,6 +299,9 @@ tcl::namespace::eval textblock {
#It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp.
#e.g $t configure -framemap_body [table_edge_map " "]
# -- --- --- --- ---
#unused?
proc table_edge_map {char} {
variable table_edge_parts
set map [list]
@ -335,6 +338,7 @@ tcl::namespace::eval textblock {
}
return $map
}
# -- --- --- --- ---
if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} {
#*** !doctools
@ -374,6 +378,7 @@ tcl::namespace::eval textblock {
variable o_columndefs
variable o_columndata
variable o_columnstates
variable o_headerdefs
variable o_headerstates
variable o_rowdefs
@ -432,6 +437,7 @@ tcl::namespace::eval textblock {
set o_columndefs [tcl::dict::create]
set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row
set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly
set o_headerdefs [tcl::dict::create] ;#by header-row
set o_headerstates [tcl::dict::create]
set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight
set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data
@ -439,12 +445,14 @@ tcl::namespace::eval textblock {
set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices.
set o_calculated_column_widths [list]
set o_column_width_algorithm "span"
set header_defaults [tcl::dict::create\
set o_opts_header_defaults [tcl::dict::create\
-colspans {}\
-values {}\
-ansibase {}\
-ansireset "\x1b\[m"\
-minheight 1\
-maxheight ""\
]
set o_opts_header_defaults $header_defaults
}
method width_algorithm {{alg ""}} {
@ -1107,10 +1115,18 @@ tcl::namespace::eval textblock {
}
}
}
#args checked - ok to update headerstates and columndefs and columnstates
#args checked - ok to update headerstates, headerdefs and columndefs and columnstates
tcl::dict::set o_columndefs $cidx $checked_opts
set o_headerstates $hstates
dict for {hidx hstate} $hstates {
#configure_header
if {![dict exists $o_headerdefs $hidx]} {
#remove calculated members -values -colspans
set hdefaults [dict remove $o_opts_header_defaults -values -colspans]
dict set o_headerdefs $hidx $hdefaults
}
}
tcl::dict::set o_columnstates $cidx $colstate
if {$args_got_headers} {
@ -1267,11 +1283,10 @@ tcl::namespace::eval textblock {
return $hcolspans
}
#should be configure_headerrow ?
method configure_header {index_expression args} {
#*** !doctools
#[call class::table [method configure_header]]
#[para] - undocumented
#[para] - configure header row-wise
#the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs.
#It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis
@ -1279,7 +1294,7 @@ tcl::namespace::eval textblock {
set num_headers [my header_count_calc]
set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression]
if {$hidx eq ""} {
error "textblock::table::configure_header - no row defined at index '$hidx'."
error "textblock::table::configure_header - no header row defined at index '$index_expression'."
}
if {$hidx > $num_headers -1} {
#assert - shouldn't happen
@ -1298,6 +1313,14 @@ tcl::namespace::eval textblock {
lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate.
}
tcl::dict::set result -values $header_row_items
#review - ensure always a headerdef record for each header?
if {[tcl::dict::exists $o_headerdefs $hidx]} {
set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]]
} else {
#warn for now
puts stderr "no headerdef record for header $hidx"
}
return $result
}
if {[llength $args] == 1} {
@ -1328,7 +1351,8 @@ tcl::namespace::eval textblock {
set colspans_by_header [my header_colspans]
set result [tcl::dict::create]
set val [tcl::dict::get $colspans_by_header $hidx]
set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"]
#ansireset not required
set returndict [tcl::dict::create option $k value $val]
}
-ansibase {
set val ???
@ -1369,8 +1393,7 @@ tcl::namespace::eval textblock {
lappend header_ansibase_items $code
}
}
set header_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items]
error "sorry - -ansibase not yet implemented for header rows"
set header_ansibase [punk::ansi::codetype::sgr_merge_singles $header_ansibase_items]
lappend checked_opts $k $header_ansibase
}
-ansireset {
@ -1472,6 +1495,10 @@ tcl::namespace::eval textblock {
#safe jumptable test
#dict for {k v} $checked_opts {}
#foreach {k v} $checked_opts {}
# headerdefs excludes -values and -colspans
set update_hdefs [tcl::dict::get $o_headerdefs $hidx]
tcl::dict::for {k v} $checked_opts {
switch -- $k {
-values {
@ -1538,8 +1565,28 @@ tcl::namespace::eval textblock {
incr c
}
}
default {
dict set update_hdefs $k $v
}
}
}
set opt_minh [tcl::dict::get $update_hdefs -minheight]
set opt_maxh [tcl::dict::get $update_hdefs -maxheight]
#todo - allow zero values to hide/collapse
# - see also configure_row
if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)"
}
if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} {
error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)"
}
if {$opt_maxh ne "" && $opt_maxh < $opt_minh} {
error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'"
}
#set o_headerstate $hidx -minheight? -maxheight? ???
tcl::dict::set o_headerdefs $hidx $update_hdefs
}
method add_row {valuelist args} {
@ -2050,7 +2097,8 @@ tcl::namespace::eval textblock {
foreach header $header_list {
set headerspans [tcl::dict::get $all_colspans $hrow]
set this_span [lindex $headerspans $cidx]
set hval $ansibase_header$header ;#no reset
#set hval $ansibase_header$header ;#no reset
set hval $header
set rowh [my header_height $hrow]
if {$hrow == 0} {
@ -2317,7 +2365,7 @@ tcl::namespace::eval textblock {
set h_lines [lrepeat $rowh $bline]
set hcell_blank [::join $h_lines \n]
# -usecache 1 ok
#frame borders will never display - so use the simplest frametype and don't apply any ansi
#frame borders will never display - so use the simplest frametype and don't apply any ansi
#puts "===>zerospan hlims: $hlims"
set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\
-boxlimits $hlims -boxmap $framesub_map $hcell_blank\
@ -2589,8 +2637,8 @@ tcl::namespace::eval textblock {
}
}
set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body]
set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header]
#set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body]
#set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header]
#set header_underlay $ansibase_header$cell_line_blank
@ -2613,7 +2661,35 @@ tcl::namespace::eval textblock {
set showing_vseps [my Showing_vseps]
for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} {
set hdr [lindex $headerlist $hrow]
set header_maxdataheight [my header_height $hrow] ;#from cached headerstates
#jjj
set header_maxdataheight [tcl::dict::get $o_headerstates $hrow maxheightseen]
#set header_maxdataheight [my header_height $hrow] ;#from cached headerstates
set headerdefminh [tcl::dict::get $o_headerdefs $hrow -minheight]
set headerdefmaxh [tcl::dict::get $o_headerdefs $hrow -maxheight]
if {"$headerdefminh$headerdefmaxh" ne "" && $headerdefminh eq $headerdefmaxh} {
set headerh $headerdefminh ;#exact height defined for the row
} else {
if {$headerdefminh eq ""} {
if {$headerdefmaxh eq ""} {
#both defs empty
set headerh $header_maxdataheight
} else {
set headerh [expr {min(1,$headerdefmaxh,$header_maxdataheight)}]
}
} else {
if {$headerdefmaxh eq ""} {
set headerh [expr {max($headerdefminh,$header_maxdataheight)}]
} else {
if {$header_maxdataheight < $headerdefminh} {
set headerh $headerdefminh
} else {
set headerh [expr {max($headerdefminh,$header_maxdataheight)}]
}
}
}
}
set headerrow_colspans [tcl::dict::get $all_colspans $hrow]
set this_span [lindex $headerrow_colspans $cidx]
@ -2654,8 +2730,7 @@ tcl::namespace::eval textblock {
set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight]
set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight]
if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} {
#an exact height is defined for the row
set rowh $rowdefminh
set rowh $rowdefminh ;#an exact height is defined for the row
} else {
if {$rowdefminh eq ""} {
if {$rowdefmaxh eq ""} {
@ -2814,6 +2889,7 @@ tcl::namespace::eval textblock {
$t destroy
}
puts stdout "columnstates: $o_columnstates"
puts stdout "headerdefs: $o_headerdefs"
puts stdout "headerstates: $o_headerstates"
tcl::dict::for {k coldef} $o_columndefs {
if {[tcl::dict::exists $o_columndata $k]} {
@ -4205,6 +4281,68 @@ tcl::namespace::eval textblock {
return $t
}
proc bookend_lines {block start {end "\x1b\[m"}} {
set out ""
foreach ln [split $block \n] {
append out $start $ln $end \n
}
return [string range $out 0 end-1]
}
proc ansibase_lines {block {newprefix ""}} {
set base ""
set out ""
if {$newprefix eq ""} {
foreach ln [split $block \n] {
set parts [punk::ansi::ta::split_codes $ln]
if {[lindex $parts 0] eq ""} {
if {[lindex $parts 1] ne "" && ![punk::ansi::codetype::is_sgr_reset [lindex $parts 1]]} {
set base [lindex $parts 1]
append out $base
} else {
append out $base
}
} else {
#leading plaintext - maintain our base
append out $base [lindex $parts 0] [lindex $parts 1]
}
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]
}
incr code_idx 2
}
append out {*}[lrange $parts 2 end] \n
}
return [string range $out 0 end-1]
} else {
set base $newprefix
foreach ln [split $block \n] {
set parts [punk::ansi::ta::split_codes $ln]
set code_idx 1
set offset 0
foreach {pt code} $parts {
if {$code_idx == 1} {
#first pt & code
if {$pt ne ""} {
#leading plaintext
set parts [linsert $parts 0 $base]
incr offset
}
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set parts [linsert $parts [expr {$code_idx+1+$offset}] $base]
incr offset
}
incr code_idx 2
}
append out {*}$parts \n
}
return [string range $out 0 end-1]
}
}
set FRAMETYPES [textblock::frametypes]
punk::args::definition [punk::lib::tstr -return string {
*id textblock::list_as_table
@ -4606,12 +4744,22 @@ tcl::namespace::eval textblock {
return [punk::char::ansifreestring_width $tl]
}
#uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function.
proc string_length_line_max textblock {
tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
proc string_length_line_max {textblock} {
#tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
set max 0
foreach ln [split $textblock \n] {
if {[tcl::string::length $ln] > $max} {set max [tcl::string::length $ln]}
}
return $max
}
#*slightly* slower
#proc string_length_line_max {textblock} {
# tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
#}
proc string_length_line_min textblock {
tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}]
}
proc height {textblock} {
#This is the height as it will/would-be rendered - not the number of input lines purely in terms of le
#empty string still has height 1 (at least for left-right/right-left languages)
@ -4652,6 +4800,45 @@ tcl::namespace::eval textblock {
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size2 {textblock} {
if {$textblock eq ""} {
return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
#strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack
if {[tcl::string::last \t $textblock] >= 0} {
if {[tcl::info::exists punk::console::tabwidth]} {
set tw $::punk::console::tabwidth
} else {
set tw 8
}
set textblock [textutil::tabify::untabify2 $textblock $tw]
}
#ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests
if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} {
set textblock [punk::ansi::ansistripraw $textblock]
}
if {[tcl::string::last \n $textblock] >= 0} {
#set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]]
set lines [split $textblock \n]
set num_le [expr {[llength $lines]-1}]
#set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]]
set width 0
foreach ln $lines {
set w [::punk::char::ansifreestring_width $ln]
if {$w > $width} {
set width $w
}
}
} else {
set num_le 0
set width [punk::char::ansifreestring_width $textblock]
}
#set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list
#our concept of block-height is likely to be different to other line-counting mechanisms
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize <data>]] width height
}
proc size_as_opts {textblock} {
set sz [size $textblock]
return [dict create -width [dict get $sz width] -height [dict get $sz height]]

Loading…
Cancel
Save