Browse Source

ansi fixes + tomlish

master
Julian Noble 4 months ago
parent
commit
dbb7360568
  1. 2
      src/bootsupport/modules/include_modules.config
  2. 458
      src/bootsupport/modules/overtype-1.6.5.tm
  3. 298
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  4. 22
      src/bootsupport/modules/punk/console-0.1.1.tm
  5. 6
      src/bootsupport/modules/punk/ns-0.1.0.tm
  6. BIN
      src/bootsupport/modules/test/tomlish-1.1.1.tm
  7. 37
      src/bootsupport/modules/textblock-0.1.1.tm
  8. 3357
      src/bootsupport/modules/tomlish-1.1.1.tm
  9. 18
      src/modules/punk/aliascore-999999.0a1.0.tm
  10. 298
      src/modules/punk/ansi-999999.0a1.0.tm
  11. 6
      src/modules/punk/blockletter-999999.0a1.0.tm
  12. 19
      src/modules/punk/config-0.1.tm
  13. 22
      src/modules/punk/console-999999.0a1.0.tm
  14. 5
      src/modules/punk/nav/fs-999999.0a1.0.tm
  15. 6
      src/modules/punk/ns-999999.0a1.0.tm
  16. 66
      src/modules/punk/repl-0.1.tm
  17. 26
      src/modules/punk/repl/codethread-999999.0a1.0.tm
  18. 296
      src/modules/punk/rest-999999.0a1.0.tm
  19. 3
      src/modules/punk/rest-buildversion.txt
  20. 58
      src/modules/shellfilter-0.1.9.tm
  21. 37
      src/modules/textblock-999999.0a1.0.tm
  22. 4
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config
  23. 458
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm
  24. 298
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  25. 22
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
  26. 6
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  27. BIN
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm
  28. 37
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm
  29. 3357
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.1.tm
  30. 246
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.8.tm
  31. 4
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config
  32. 458
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm
  33. 298
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  34. 22
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
  35. 6
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  36. BIN
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm
  37. 37
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm
  38. 3357
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.1.tm
  39. 246
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/uuid-1.0.8.tm
  40. 9
      src/testansi/palettes/AppleII.ans
  41. 12
      src/testansi/palettes/Solarized.ans
  42. 13
      src/testansi/palettes/Solarized_light.ans
  43. 6
      src/testansi/palettes/VSCode.ans
  44. 6
      src/testansi/palettes/Windows.ans
  45. 7
      src/testansi/palettes/windows_legacy.ans
  46. 458
      src/vendormodules/overtype-1.6.5.tm
  47. BIN
      src/vendormodules/test/tomlish-1.1.1.tm
  48. 1092
      src/vendormodules/tomlish-1.1.1.tm
  49. 458
      src/vfs/_vfscommon/modules/overtype-1.6.5.tm
  50. 18
      src/vfs/_vfscommon/modules/punk/aliascore-0.1.0.tm
  51. 298
      src/vfs/_vfscommon/modules/punk/ansi-0.1.1.tm
  52. 6
      src/vfs/_vfscommon/modules/punk/blockletter-0.1.0.tm
  53. 19
      src/vfs/_vfscommon/modules/punk/config-0.1.tm
  54. 22
      src/vfs/_vfscommon/modules/punk/console-0.1.1.tm
  55. 5
      src/vfs/_vfscommon/modules/punk/nav/fs-0.1.0.tm
  56. 6
      src/vfs/_vfscommon/modules/punk/ns-0.1.0.tm
  57. 66
      src/vfs/_vfscommon/modules/punk/repl-0.1.tm
  58. 26
      src/vfs/_vfscommon/modules/punk/repl/codethread-0.1.0.tm
  59. 296
      src/vfs/_vfscommon/modules/punk/rest-0.1.0.tm
  60. 58
      src/vfs/_vfscommon/modules/shellfilter-0.1.9.tm
  61. BIN
      src/vfs/_vfscommon/modules/test/tomlish-1.1.1.tm
  62. 37
      src/vfs/_vfscommon/modules/textblock-0.1.1.tm
  63. 1092
      src/vfs/_vfscommon/modules/tomlish-1.1.1.tm

2
src/bootsupport/modules/include_modules.config

@ -21,6 +21,8 @@ set bootsupport_modules [list\
src/vendormodules uuid\
src/vendormodules md5\
src/vendormodules sha1\
src/vendormodules tomlish\
src/vendormodules test::tomlish\
modules punkcheck\
modules natsort\
modules punk::ansi\

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

@ -233,7 +233,6 @@ tcl::namespace::eval overtype {
-width \uFFEF\
-height \uFFEF\
-startcolumn 1\
-wrap 0\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
@ -243,11 +242,13 @@ tcl::namespace::eval overtype {
-exposed1 \uFFFD\
-exposed2 \uFFFD\
-experimental 0\
-cp437 1\
-cp437 0\
-looplimit \uFFEF\
-crm_mode 0\
-reverse_mode 0\
-insert_mode 0\
-wrap 0\
-info 0\
-console {stdin stdout stderr}\
]
#expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally..
@ -263,14 +264,19 @@ tcl::namespace::eval overtype {
#-ellipsis args not used if -wrap is true
foreach {k v} $argsflags {
switch -- $k {
-looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace
-looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace
- -transparent - -exposed1 - -exposed2 - -experimental
- -expand_right - -appendlines
- -reverse_mode - -crm_mode - -insert_mode
- -cp437
- -console {
- -info - -console {
tcl::dict::set opts $k $v
}
-wrap - -autowrap_mode {
#temp alias -autowrap_mode for consistency with renderline
#todo -
tcl::dict::set opts -wrap $v
}
default {
error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]"
}
@ -280,10 +286,6 @@ tcl::namespace::eval overtype {
# -- --- --- --- --- ---
#review - expand_left for RTL text?
set opt_expand_right [tcl::dict::get $opts -expand_right]
#####
# review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?.
set opt_wrap [tcl::dict::get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo)
#####
#for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line.
set opt_width [tcl::dict::get $opts -width]
set opt_height [tcl::dict::get $opts -height]
@ -298,50 +300,34 @@ tcl::namespace::eval overtype {
set opt_crm_mode [tcl::dict::get $opts -crm_mode]
set opt_reverse_mode [tcl::dict::get $opts -reverse_mode]
set opt_insert_mode [tcl::dict::get $opts -insert_mode]
#####
# review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?.
set opt_autowrap_mode [tcl::dict::get $opts -wrap]
#??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo)
#####
# -- --- --- --- --- ---
set opt_cp437 [tcl::dict::get $opts -cp437]
set opt_info [tcl::dict::get $opts -info]
#initial state for renderspace 'terminal' reset
set initial_state [dict create\
-width $opt_width\
-height $opt_height\
-crm_mode $opt_crm_mode\
-reverse_mode $opt_reverse_mode\
-insert_mode $opt_insert_mode\
-cp437 $opt_cp437\
]
# ----------------------------
# -experimental dev flag to set flags etc
# ----------------------------
set data_mode 0
set info_mode 0
set edit_mode 0
set opt_experimental [tcl::dict::get $opts -experimental]
foreach o $opt_experimental {
switch -- $o {
old_mode {
set info_mode 1
}
data_mode {
set data_mode 1
}
info_mode {
set info_mode 1
}
edit_mode {
set edit_mode 1
}
}
}
# ----------------------------
#modes
set insert_mode $opt_insert_mode ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l
set autowrap_mode $opt_wrap
set reverse_mode $opt_reverse_mode
set crm_mode $opt_crm_mode
set underblock [tcl::string::map {\r\n \n} $underblock]
@ -367,6 +353,20 @@ tcl::namespace::eval overtype {
set renderwidth $opt_width
set renderheight $opt_height
}
#initial state for renderspace 'terminal' reset
set initial_state [dict create\
renderwidth $renderwidth\
renderheight $renderheight\
crm_mode $opt_crm_mode\
reverse_mode $opt_reverse_mode\
insert_mode $opt_insert_mode\
autowrap_mode $opt_autowrap_mode\
cp437 $opt_cp437\
]
#modes
#e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l
#opt_startcolumn ?? - DECSLRM ?
set vtstate $initial_state
# -- --- --- ---
#REVIEW - do we need ansi resets in the underblock?
@ -494,50 +494,55 @@ tcl::namespace::eval overtype {
}
#review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary -
#but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l
set renderargs [list -experimental $opt_experimental\
-cp437 $opt_cp437\
-info 1\
-crm_mode $crm_mode\
-insert_mode $insert_mode\
-autowrap_mode $autowrap_mode\
-reverse_mode $reverse_mode\
-cursor_restore_attributes $cursor_saved_attributes\
-transparent $opt_transparent\
-width $renderwidth\
-exposed1 $opt_exposed1\
-exposed2 $opt_exposed2\
-expand_right $opt_expand_right\
-cursor_column $col\
-cursor_row $row\
set renderargs [list -experimental $opt_experimental\
-cp437 $opt_cp437\
-info 1\
-crm_mode [tcl::dict::get $vtstate crm_mode]\
-insert_mode [tcl::dict::get $vtstate insert_mode]\
-autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\
-reverse_mode [tcl::dict::get $vtstate reverse_mode]\
-cursor_restore_attributes $cursor_saved_attributes\
-transparent $opt_transparent\
-width [tcl::dict::get $vtstate renderwidth]\
-exposed1 $opt_exposed1\
-exposed2 $opt_exposed2\
-expand_right $opt_expand_right\
-cursor_column $col\
-cursor_row $row\
$undertext\
$overtext\
]
set LASTCALL $renderargs
set rinfo [renderline {*}$renderargs]
set instruction [tcl::dict::get $rinfo instruction]
set insert_mode [tcl::dict::get $rinfo insert_mode]
set autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;#
set reverse_mode [tcl::dict::get $rinfo reverse_mode]
set instruction [tcl::dict::get $rinfo instruction]
tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode]
tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode]
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;#
tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode]
#how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack?
# - review - the answer is probably that we don't need to - it is set/reset only during application of overtext
set crm_mode [tcl::dict::get $rinfo crm_mode]
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set overflow_right_column [tcl::dict::get $rinfo overflow_right_column]
set unapplied [tcl::dict::get $rinfo unapplied]
set unapplied_list [tcl::dict::get $rinfo unapplied_list]
set post_render_col [tcl::dict::get $rinfo cursor_column]
set post_render_row [tcl::dict::get $rinfo cursor_row]
set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position]
set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes]
set visualwidth [tcl::dict::get $rinfo visualwidth]
set insert_lines_above [tcl::dict::get $rinfo insert_lines_above]
set insert_lines_below [tcl::dict::get $rinfo insert_lines_below]
tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay]
#Note carefully the difference betw overflow_right and unapplied.
#overflow_right may need to be included in next run before the unapplied data
#overflow_right most commonly has data when in insert_mode
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set overflow_right_column [tcl::dict::get $rinfo overflow_right_column]
set unapplied [tcl::dict::get $rinfo unapplied]
set unapplied_list [tcl::dict::get $rinfo unapplied_list]
set post_render_col [tcl::dict::get $rinfo cursor_column]
set post_render_row [tcl::dict::get $rinfo cursor_row]
set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position]
set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes]
set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line
set insert_lines_above [tcl::dict::get $rinfo insert_lines_above]
set insert_lines_below [tcl::dict::get $rinfo insert_lines_below]
tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay]
#lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay]
set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]
if {0 && $reverse_mode} {
if {0 && [tcl::dict::get $vtstate reverse_mode]} {
#test branch - todo - prune
puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered"
#review
@ -593,19 +598,29 @@ tcl::namespace::eval overtype {
#todo - handle potential insertion mode as above for cursor restore?
#keeping separate branches for debugging - review and merge as appropriate when stable
tcl::dict::incr instruction_stats $instruction
switch -- $instruction {
set instruction_type [lindex $instruction 0] ;#some instructions have params
tcl::dict::incr instruction_stats $instruction_type
switch -- $instruction_type {
reset {
#reset the 'renderspace terminal' (not underlying terminal)
set row 1
set col 1
set vtstate [tcl::dict::merge $vtstate $initial_state]
#todo - clear screen
}
{} {
#end of supplied line input
#lf included in data
set row $post_render_row
set col $post_render_col
if {![llength $unapplied_list]} {
if {$overflow_right ne ""} {
incr row
}
} else {
puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)"
}
set col $opt_startcolumn
}
up {
@ -708,17 +723,18 @@ tcl::namespace::eval overtype {
puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]"
set sub_info [overtype::renderline -info 1\
-width $renderwidth\
-insert_mode $insert_mode\
-autowrap_mode $autowrap_mode\
set sub_info [overtype::renderline\
-info 1\
-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]\
""\
$overflow_right\
]
set foldline [tcl::dict::get $sub_info result]
set insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
set autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
set foldline [tcl::dict::get $sub_info result]
tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
linsert outputlines $renderedrow $foldline
#review - row & col set by restore - but not if there was no save..
}
@ -745,6 +761,53 @@ tcl::namespace::eval overtype {
set col $post_render_col
#overflow + unapplied?
}
clear_and_move {
#e.g 2J
if {$post_render_row > [llength $outputlines]} {
set row [llength $outputlines]
} else {
set row $post_render_row
}
set col $post_render_col
set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant
set clearedlines [list]
foreach ln $outputlines {
lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m
if 0 {
set lineparts [punk::ansi::ta::split_codes $ln]
set numcells 0
foreach {pt _code} $lineparts {
if {$pt ne ""} {
foreach grapheme [punk::char::grapheme_split $pt] {
switch -- $grapheme {
" " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? -
a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y -
z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
incr numcells 1
}
default {
if {$grapheme eq "\u0000"} {
incr numcells 1
} else {
incr numcells [grapheme_width_cached $grapheme]
}
}
}
}
}
}
#replays/resets each line
lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m
}
}
set outputlines $clearedlines
#todo - determine background/default to be in effect - DECECM ?
puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]"
#lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0]
}
lf_start {
#raw newlines
# ----------------------
@ -780,27 +843,48 @@ tcl::namespace::eval overtype {
append rendered $overflow_right
set overflow_right ""
} else {
#review - we should really make renderline do the work...?
set overflow_width [punk::ansi::printing_length $overflow_right]
if {$visualwidth + $overflow_width <= $renderwidth} {
append rendered $overflow_right
set overflow_right ""
} else {
if {$visualwidth < $renderwidth} {
set graphemes [punk::char::grapheme_split $overflow_width]
set add ""
set addlen $visualwidth
set remaining_overflow $graphemes
foreach g $graphemes {
set w [overtype::grapheme_width_cached]
if {$addlen + $w <= $renderwidth} {
append add $g
incr addlen $w
lpop remaining_overflow
} else {
break
}
if {[tcl::dict::get $vtstate autowrap_mode]} {
set outputlines [linsert $outputlines $renderedrow $overflow_right]
set overflow_right ""
set row [expr {$renderedrow + 2}]
} else {
set overflow_right "" ;#abandon
}
if {0 && $visualwidth < $renderwidth} {
puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth"
error "incomplete - abandon?"
set overflowparts [punk::ansi::ta::split_codes $overflow_right]
set remaining_overflow $overflowparts
set filled 0
foreach {pt code} $overflowparts {
lpop remaining_overflow 0
if {$pt ne ""} {
set graphemes [punk::char::grapheme_split $pt]
set add ""
set addlen $visualwidth
foreach g $graphemes {
set w [overtype::grapheme_width_cached $g]
if {$addlen + $w <= $renderwidth} {
append add $g
incr addlen $w
} else {
set filled 1
break
}
}
append rendered $add
}
if {!$filled} {
lpop remaining_overflow 0 ;#pop code
}
}
append rendered $add
set overflow_right [join $remaining_overflow ""]
}
}
@ -829,14 +913,16 @@ tcl::namespace::eval overtype {
#we may also have other control sequences that came after col 80 e.g cursor save
if 0 {
set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]]
set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs]
set rhs ""
set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]]
set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs]
set rhs ""
#assertion - there should be no overflow..
puts $lhs
#assertion - there should be no overflow..
puts $lhs
}
if {![tcl::dict::get $vtstate insert_mode]} {
assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode
}
assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right
set row $post_render_row
#set row $renderedrow
@ -981,7 +1067,7 @@ tcl::namespace::eval overtype {
#normal single-width grapheme overflow
#puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]"
set row $post_render_row ;#renderline will not advance row when reporting overflow char
if {$autowrap_mode} {
if {[tcl::dict::get $vtstate autowrap_mode]} {
incr row
set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ??
} else {
@ -1014,7 +1100,7 @@ tcl::namespace::eval overtype {
#2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts
#todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc
if {$autowrap_mode} {
if {[tcl::dict::get $vtstate autowrap_mode]} {
if {$renderwidth < 2} {
#edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character
set idx 0
@ -1055,6 +1141,14 @@ tcl::namespace::eval overtype {
set row $post_render_row
set col $post_render_col
}
set_window_title {
set newtitle [lindex $instruction 1]
puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'"
#
}
reset_colour_palette {
puts stderr "overtype::renderspace instruction '$instruction' unimplemented"
}
default {
puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'"
}
@ -1062,7 +1156,7 @@ tcl::namespace::eval overtype {
}
if {!$opt_expand_right && !$autowrap_mode} {
if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} {
#not allowed to overflow column or wrap therefore we get overflow data to truncate
if {[tcl::dict::get $opts -ellipsis]} {
set show_ellipsis 1
@ -1160,11 +1254,22 @@ tcl::namespace::eval overtype {
}
set result [join $outputlines \n]
if {$info_mode} {
if {!$opt_info} {
return $result
} else {
#emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window?
#append result \n$instruction_stats\n
set inforesult [dict create\
result $result\
last_instruction $instruction\
instruction_stats $instruction_stats\
]
if {$opt_info == 2} {
return [pdict -channel none inforesult]
} else {
return $inforesult
}
}
return $result
}
#todo - left-right ellipsis ?
@ -2368,14 +2473,22 @@ tcl::namespace::eval overtype {
} else {
#linefeed occurred in middle or at end of text
#puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx"
incr cursor_row
if {$idx == -1 || $overflow_idx > $idx} {
#don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
if {$insert_mode == 0} {
incr cursor_row
if {$idx == -1 || $overflow_idx > $idx} {
#don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
}
set instruction lf_mid
priv::render_unapplied $overlay_grapheme_control_list $gci
break
} else {
incr cursor_row
#don't adjust the overflow_idx
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction lf_mid
break ;# could have overdata following the \n - don't keep processing
}
set instruction lf_mid
priv::render_unapplied $overlay_grapheme_control_list $gci
break
}
}
@ -3077,8 +3190,11 @@ tcl::namespace::eval overtype {
set idx [expr {$cursor_column -1}]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
if {[llength $outcols]} {
priv::render_erasechar 0 [llength $outcols]
}
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction move
set instruction clear_and_move
break
}
3 {
@ -3749,6 +3865,72 @@ tcl::namespace::eval overtype {
}
7OSC - 8OSC {
# OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit
if {[tcl::string::index $codenorm end] eq "\007"} {
set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007
} else {
set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\
}
set first_colon [tcl::string::first {;} $code_content]
if {$first_colon == -1} {
#there probably should always be a colon - but we'll try to make sense of it without
set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007
} else {
set osc_code [tcl::string::range $code_content 0 $first_colon-1]
}
switch -exact -- $osc_code {
2 {
set newtitle [tcl::string::range $code_content 2 end]
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction [list set_window_title $newtitle]
break
}
4 {
#OSC 4 - set colour palette
#can take multiple params
#e.g \x1b\]4\;1\;red\;2\;green\x1b\\
set params [tcl::string::range $code_content 1 end]
puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 {
#OSC 10 through 17 - so called 'dynamic colours'
#can take multiple params - each successive parameter changes the next colour in the list
#- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more
#10 change text foreground colour
#11 change text background colour
#12 change text cursor colour
#13 change mouse foreground colour
#14 change mouse background colour
#15 change tektronix foreground colour
#16 change tektronix background colour
#17 change highlight colour
set params [tcl::string::range $code_content 2 end]
puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
18 {
#why is this not considered one of the dynamic colours above?
#https://www.xfree86.org/current/ctlseqs.html
#tektronix cursor color
puts stderr "overtype::renderline OSC 18 - set tektronix cursor color 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
puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction [list reset_colour_palette]
break
}
default {
puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
}
default {
@ -3791,6 +3973,23 @@ tcl::namespace::eval overtype {
#how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW
set in_overflow 1
}
set trailing_nulls 0
foreach ch [lreverse $outcols] {
if {$ch eq "\u0000"} {
incr trailing_nulls
} else {
break
}
}
if {$trailing_nulls} {
set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}]
} else {
set first_tail_null_posn -1
}
#puts stderr "first_tail_null_posn: $first_tail_null_posn"
#puts stderr "colview: [ansistring VIEW $outcols]"
foreach ch $outcols {
#puts "---- [ansistring VIEW $ch]"
@ -3865,8 +4064,17 @@ tcl::namespace::eval overtype {
}
append outstring $gxleader
append outstring $sgrleader
if {$idx+1 < $cursor_column} {
append outstring [tcl::string::map {\u0000 " "} $ch]
if {$ch eq "\u0000"} {
if {$cp437_glyphs} {
#map all nulls including at tail to space
append outstring " "
} else {
if {$trailing_nulls && $i < $first_tail_null_posn} {
append outstring " " ;#map inner nulls to space
} else {
append outstring \u0000
}
}
} else {
append outstring $ch
}
@ -3874,12 +4082,20 @@ tcl::namespace::eval overtype {
incr i
}
#flower.ans good test for null handling - reverse line building
if {![ansistring length $overflow_right]} {
set outstring [tcl::string::trimright $outstring "\u0000"]
}
set outstring [tcl::string::map {\u0000 " "} $outstring]
set overflow_right [tcl::string::trimright $overflow_right "\u0000"]
set overflow_right [tcl::string::map {\u0000 " "} $overflow_right]
#review - presence of overflow_right doesn't indicate line's trailing nulls should remain.
#The cells could have been erased?
#if {!$cp437_glyphs} {
# #if {![ansistring length $overflow_right]} {
# # set outstring [tcl::string::trimright $outstring "\u0000"]
# #}
# set outstring [tcl::string::trimright $outstring "\u0000"]
# set outstring [tcl::string::map {\u0000 " "} $outstring]
#}
#REVIEW
#set overflow_right [tcl::string::trimright $overflow_right "\u0000"]
#set overflow_right [tcl::string::map {\u0000 " "} $overflow_right]
set replay_codes ""
if {[llength $understacks] > 0} {
@ -4207,8 +4423,9 @@ tcl::namespace::eval overtype::priv {
upvar outcols o
upvar understacks ustacks
upvar understacks_gx gxstacks
upvar replay_codes_overlay replay
#ECH clears character attributes from erased character positions
#ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater.
#ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater.
if {![tcl::string::is integer -strict $count] || $count < 1} {
error "render_erasechar count must be integer >= 1"
}
@ -4223,8 +4440,9 @@ tcl::namespace::eval overtype::priv {
}
set num [expr {$end - $start + 1}]
set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space?
set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list]]]
set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]]
#DECECM ???
set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]]
set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review
return
}
proc render_setchar {i c } {

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

@ -413,6 +413,7 @@ tcl::namespace::eval punk::ansi {
tcl::namespace::export\
{a?} {a+} a \
ansistring\
ansiwrap\
convert*\
clear*\
cursor_*\
@ -722,77 +723,11 @@ tcl::namespace::eval punk::ansi {
#candidate for zig/c implementation?
proc stripansi2 {text} {
set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters
join [::punk::ansi::ta::split_at_codes $text] ""
}
proc stripansi1 {text} {
#todo - character set selection - SS2 SS3 - how are they terminated? REVIEW
variable escape_terminals ;#dict
variable ::punk::ansi::ta::standalone_code_map ;#map to empty string
set text [convert_g0 $text]
set text [tcl::string::map $standalone_code_map $text]
#e.g standalone 2 byte and 3 byte VT100(?) sequences - some of these work in wezterm
#\x1b#3 double-height letters top half
#\x1b#4 double-height letters bottom half
#\x1b#5 single-width line
#\x1b#6 double-width line
#\x1b#8 dec test fill screen
#we process char by char - line-endings whether \r\n or \n should be processed as per any other character.
#Theoretically line endings can occur within an ST payload (review e.g title?)
#ecma standard says: The character string following may consist of any bit combination, except those representing SOS or STRING TERMINATOR (ST)
set inputlist [split $text ""]
set outputlist [list]
set in_escapesequence 0
#assumption - text already 'rendered' - ie no cursor movement controls . (what about backspace and lone carriage returns - they are horizontal cursor movements)
set i 0
foreach u $inputlist {
set v [lindex $inputlist $i+1]
set uv ${u}${v}
if {$in_escapesequence eq "2b"} {
#2nd byte - done.
set in_escapesequence 0
} elseif {$in_escapesequence != 0} {
set endseq [tcl::dict::get $escape_terminals $in_escapesequence]
if {$u in $endseq} {
set in_escapesequence 0
} elseif {$uv in $endseq} {
set in_escapesequence 2b ;#flag next byte as last in sequence
}
} else {
#handle both 7-bit and 8-bit CSI and OSC
if {[regexp {^(?:\033\[|\u009b)} $uv]} {
set in_escapesequence CSI
} elseif {[regexp {^(?:\033\]|\u009d)} $uv]} {
set in_escapesequence OSC
} elseif {[regexp {^(?:\033P|\u0090)} $uv]} {
set in_escapesequence DCS
} elseif {[regexp {^(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)} $uv]} {
#SOS,PM,APC - all terminated with ST
set in_escapesequence MISC
} else {
lappend outputlist $u
}
}
incr i
}
return [join $outputlist ""]
}
#review - what happens when no terminator?
#todo - map other character sets to unicode equivs? There seems to be little support for other than the DEC special graphics set.. ISO2022 character switching not widely supported - may be best considered deprecated(?)
# convert esc(0 -> esc(B graphics sequences to single char unicode equivalents e.g box drawing set
@ -2029,7 +1964,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#[para]Return an ansi string representing a table of codes and a panel showing the colours
variable SGR_setting_map
variable SGR_colour_map
set fcposn [lsearch $args "forcecol*"]
set fcposn [lsearch $args "force*"]
set fc ""
set opt_forcecolour 0
if {$fcposn >= 0} {
@ -2409,7 +2344,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything.
set forcecolour 0
set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour
set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour
if {$fcpos >= 0} {
set forcecolour 1
set args [lremove $args $fcpos]
@ -2767,7 +2702,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything.
set forcecolour 0
set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour
set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour
if {$fcpos >=0} {
set forcecolour 1
set args [lremove $args $fcpos]
@ -3199,6 +3134,16 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
return $out
}
proc move_emitblock {row col textblock} {
#*** !doctools
#[call [fun move_emitblock] [arg row] [arg col] [arg textblock]]
set commands ""
foreach ln [split $textblock \n] {
append commands [punk::ansi::move_emit $row $col $ln]
incr row
}
return $commands
}
proc move_forward {{n 1}} {
#*** !doctools
#[call [fun move_forward] [arg n]]
@ -3315,18 +3260,90 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
#Alt screen buffer
#Alt screen buffer - smcup/rmcup ti/te
#Note \x1b\[?47h doesn't work at all in some terminals (e.g alacritty,cmd on windows and reportedly kitty)
#It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals.
#see: https://xn--rpa.cc/irl/term.html
#1049 (introduced by xterm in 1998?) considered the more modern version?
#1047,1048,1049 xterm private modes are 'composite' control sequences as replacement for original 47 sequence
#1049 - includes save cursor,switch to alt screen, clear screen
#e.g ? (below example not known to be exactly what 1049 does - but it's something similar)
#SMCUP
# \x1b7 (save cursor)
# \x1b\[?47h (switch)
# \x1b\[2J (clear screen)
#RMCUP
# \x1b\[?47l (switch back)
# \x1b8 (restore cursor)
#1047 - clear screen on the way out (ony if actually on alt screen)
proc enable_alt_screen {} {
#tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen?
#\x1b\[?1049h ;#xterm
return \x1b\[?47h
return \x1b\[?1049h
}
proc disable_alt_screen {} {
#tput rmcup outputs \x1b\[?1049l\x1b\[23\;0\;0t]
#\x1b\[?1049l
return \x1b\[?1049l
}
#47 - less widely supported(?) doesn't restore cursor or clear alt screen
proc enable_alt_screen2 {} {
return \x1b\[?47h
}
proc disable_alt_screen2 {} {
return \x1b\[?47l
}
proc term_colour_fg {colour} {
return "\x1b\]10\;$colour\x1b\\"
}
proc term_color_fg {colour} {
return "\x1b\]10\;$colour\x1b\\"
}
proc term_colour_bg {colour} {
return "\x1b\]11\;$colour\x1b\\"
}
proc term_color_bg {colour} {
return "\x1b\]11\;$colour\x1b\\"
}
proc term_colour_cursor {colour} {
return "\x1b\]12\;$colour\x1b\\"
}
proc term_color_cursor {colour} {
return "\x1b\]12\;$colour\x1b\\"
}
proc term_colour_pointer_fg {colour} {
return "\x1b\]13\;$colour\x1b\\"
}
proc term_color_pointer_fg {colour} {
return "\x1b\]13\;$colour\x1b\\"
}
proc term_colour_pointer_bg {colour} {
return "\x1b\]14\;$colour\x1b\\"
}
proc term_color_pointer_bg {colour} {
return "\x1b\]14\;$colour\x1b\\"
}
#15,16 tektronix fg, tektronix bg ???
proc term_colour_highlight_bg {colour} {
return "\x1b\]17\;$colour\x1b\\"
}
proc term_color_highlight_bg {colour} {
return "\x1b\]17\;$colour\x1b\\"
}
#18 tektronix cursor colour ???
proc term_colour_highlight_fg {colour} {
return "\x1b\]19\;$colour\x1b\\"
}
proc term_color_highlight_fg {colour} {
return "\x1b\]19\;$colour\x1b\\"
}
#22 pointer shape - there are other methods too - not known to work on windows terminal based VTs - review
proc term_colour_reset {} {
return "\x1b\]104\;\x1b\\"
}
proc term_color_reset {} {
return "\x1b\]104\;\x1b\\"
}
# -- --- ---
proc erase_line {} {
@ -4398,6 +4415,10 @@ tcl::namespace::eval punk::ansi::ta {
variable re_ansi_detect_open
expr {[regexp $re_ansi_detect_open $text]}
}
proc detect_st_open {text} {
variable re_ST_open
expr {[regexp $re_ST_open $text]}
}
#not in perl ta
proc detect_csi {text} {
@ -4672,7 +4693,8 @@ tcl::namespace::eval punk::ansi::class {
}
oo::class create base_renderer {
variable o_width
variable o_wrap o_overflow o_appendlines o_looplimit
variable o_autowrap_mode
variable o_overflow o_appendlines o_looplimit
variable o_cursor_column o_cursor_row
#variable o_render_index ;#index of input (from_ansistring) grapheme/ansi-code that *has* been rendered
@ -4690,25 +4712,33 @@ tcl::namespace::eval punk::ansi::class {
}
tcl::namespace::path $nspath
#-- --
if {[llength $args] < 2} {
error {usage: ?-width <int>? ?-wrap [1|0]? ?-overflow [1|0]? from_ansistring to_ansistring}
if {[llength $args] < 1} {
error {usage: ?-width <int>? ?-height <height>? ?-autowrap_mode [1|0]? ?-overflow [1|0]? from_ansistring}
}
lassign [lrange $args end-1 end] from_ansistring to_ansistring
#lassign [lrange $args end-1 end] from_ansistring to_ansistring
set from_ansistring [lindex $args end]
set opts [tcl::dict::create\
-width \uFFEF\
-wrap 1\
-overflow 0\
-appendlines 1\
-looplimit 15000\
-experimental {}\
-cursor_column 1\
-cursor_row 1\
-width \uFFEF\
-height \uFFEF\
-overflow 0\
-appendlines 1\
-looplimit 15000\
-experimental {}\
-cursor_column 1\
-cursor_row 1\
-insert_mode 0\
-autowrap_mode 1\
-initial_ansistring ""\
]
puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring"
set argsflags [lrange $args 0 end-2]
foreach {k v} $argsflags {
switch -- $k {
-width - -wrap - -overflow - -appendlines - -looplimit - -experimental {
-width - -height -
-overflow - -appendlines - -looplimit - -experimental -
-autowrap_mode -
-insert_mode -
-initial_ansistring {
tcl::dict::set opts $k $v
}
default {
@ -4717,8 +4747,19 @@ tcl::namespace::eval punk::ansi::class {
}
}
}
set initial_ansistring [tcl::dict::get $opts -initial_ansistring]
if {$initial_ansistring eq ""} {
set to_ansistring [punk::ansi::class::class_ansistring new ""]
} else {
#todo - verify obj vs raw string
set to_ansistring $initial_ansistring
}
puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring"
set o_width [tcl::dict::get $opts -width]
set o_wrap [tcl::dict::get $opts -wrap]
set o_height [tcl::dict::get $opts -height]
set o_autowrap_mode [tcl::dict::get $opts -autowrap_mode]
set o_insert_mode [tcl::dict::get $opts -insert_mode]
set o_overflow [tcl::dict::get $opts -overflow]
set o_appendlines [tcl::dict::get $opts -appendlines]
set o_looplimit [tcl::dict::get $opts -looplimit]
@ -4736,6 +4777,9 @@ tcl::namespace::eval punk::ansi::class {
method eval_in {script} {
eval $script
}
method renderbuf {} {
return $o_to_ansistring
}
method cursor_column {{col ""}} {
if {$col eq ""} {
return $o_cursor_column
@ -4755,6 +4799,12 @@ tcl::namespace::eval punk::ansi::class {
set o_cursor_row $row
}
#set/query cursor state
method cursor_state {args} {
lassign $args r c
return [dict create row [my cursor_row $r] column [my cursor_column $c]]
}
#consider scroll area
#we need to render to something with a concept of viewport, offscreen above,below,left,right?
method rendernext {} {
@ -4834,7 +4884,8 @@ tcl::namespace::eval punk::ansi::class {
#set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext]
}
}
#renderspace equivalent? channel based?
#todo
$o_to_ansistring append $newtext
return [tcl::dict::create type $type_rendered rendercount $rendercount start_count_unrendered $start_elements_unrendered end_count_unrendered $end_elements_unrendered]
@ -4960,11 +5011,10 @@ tcl::namespace::eval punk::ansi::class {
if {$o_renderer ne ""} {
append result \n " renderer obj: $o_renderer"
append result \n " renderer class: [info object class $o_renderer]"
}
if {$o_renderout ne ""} {
append result \n " render target ansistring: $o_renderout"
append result \n " render target has ansi : [$o_renderout has_ansi]"
append result \n " render target count : [$o_renderout count]"
set renderstring [$o_renderer renderbuf]
append result \n " render target ansistring: $renderstring"
append result \n " render target has ansi : [$renderstring has_ansi]"
append result \n " render target count : [$renderstring count]"
}
if {$verbose} {
append result \n "ansisplits listing"
@ -5052,7 +5102,8 @@ tcl::namespace::eval punk::ansi::class {
}
method strippedlength {} {
if {![llength $o_ansisplits]} {my MakeSplit}
#review
return [string length [join $o_ptlist ""]]
}
#returns the ansiless string - doesn't affect the stored state other than initialising it's internal state if it wasn't already
method stripped {} {
@ -5119,10 +5170,9 @@ tcl::namespace::eval punk::ansi::class {
if {$rtype ni $rtypes} {
error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)"
}
if {$o_renderout eq ""} {
#tell ansistring that it's a renderbuf for another ansistring? point it to the renderer or the parent ansistring?
set o_renderout [punk::ansi::class::class_ansistring new ""]
}
#if {$o_renderout eq ""} {
# set o_renderout [punk::ansi::class::class_ansistring new ""]
#}
if {$o_renderer ne ""} {
set oinfo [info object class $o_renderer]
set tail [tcl::namespace::tail $oinfo]
@ -5130,13 +5180,15 @@ tcl::namespace::eval punk::ansi::class {
if {$rtype ne $currenttype} {
puts "switch rendertype from $currenttype to $rtype - destroying renderer and creating a new one"
$o_renderer destroy ;#what happens to data in target ansistring obj? when does it make sense to keep output and keep rendering vs clearing?
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
#set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]]
} else {
return $currenttype
}
} else {
puts "creating first renderer"
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
#set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]]
}
}
#--- progressive rendering buffer - another ansistring object
@ -5149,10 +5201,13 @@ tcl::namespace::eval punk::ansi::class {
return $o_renderwidth
}
#re-render if needed?
puts stderr "renderwidth todo? re-render?"
set o_renderwidth $rw
}
method renderer {} {
return $o_renderer
}
method render_state {} {
#? report state of render.. we will primarily be using plaintext/ansisequence as the chunk/operation boundary
#but - as we can append char sequences directly to the tail split - it's not enough to track which split element we have rendered - but we also need how many graphemes or code sequences we are into the last split.
@ -5160,10 +5215,36 @@ tcl::namespace::eval punk::ansi::class {
}
method renderbuf {} {
#get the underlying renderobj - if any
return $o_renderout ;#also class_ansistring
#return $o_renderout ;#also class_ansistring
return [$o_renderer renderbuf]
}
method render {} {
method render {{maxgraphemes ""}} {
#full render - return buffer ansistring
set do_render 1
set grapheme_count 0
set other_count 0
if {$maxgraphemes eq ""} {
while {$do_render} {
set rendition [my rendernext]
set do_render [dict get $rendition rendercount]
if {[dict get $rendition type] eq "g"} {
incr grapheme_count $do_render
} else {
incr other_count $do_render
}
}
} else {
while {$do_render && $grapheme_count <= $maxgraphemes} {
set rendition [my rendernext]
set do_render [dict get $rendition rendercount]
if {[dict get $rendition type] eq "g"} {
incr grapheme_count $do_render
} else {
incr other_count $do_render
}
}
}
return [dict create graphemes $grapheme_count other $other_count]
}
method rendernext {} {
#render next available pt/code chunk only - not to end of available input
@ -5198,6 +5279,13 @@ tcl::namespace::eval punk::ansi::class {
#i.e a 'rendered' ANSI string should contain just ANSI SGR character attributes and linefeeds for rows
#Knowing which is which can be helpful as far as use of any methods which use the concepts of terminal row/column
#like Tcl's append class_ansistring append returns the result directly - which for ANSI - can be inconvenient in the terminal
#class_ansistring append_string is a convenience wrapper to avoid returning the raw result
method append_string {args} {
my append {*}$args
return
}
#analagous to Tcl string append
#MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient
method append {args} {
@ -5369,7 +5457,7 @@ tcl::namespace::eval punk::ansi::class {
}
#method append_and_render - append and render up to end of appended data at same time
#method append_and_render? - append and render up to end of appended data at same time
method view {args} {
if {$o_string eq ""} {

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

@ -864,6 +864,7 @@ namespace eval punk::console {
#Turning ansi off only stops new ansi being generated - but what about codes stored in configurations of existing elements such as tables/frames?
#It will stop underlines/bold/reverse as well as SGR colours
#what about ansi movement codes etc?
#we already have colour on|off which disables SGR codes in a+ etc as well as stderr/stdout channel transforms
proc ansi {{onoff {}}} {
variable ansi_wanted
if {[string length $onoff]} {
@ -891,6 +892,7 @@ namespace eval punk::console {
}
}
catch {punk::repl::reset_prompt}
puts stderr "::punk::console::ansi - use 'colour' command to turn SGR codes on/off"
return [expr {$ansi_wanted}]
}
@ -1295,10 +1297,10 @@ namespace eval punk::console {
if {![catch {twapi::set_console_title $windowtitle} result]} {
return $windowtitle
} else {
error "punk::console::titleset failed to set title - try punk::console::ansi::titleset"
error "punk::console::local::titleset failed to set title - try punk::console::ansi::titleset"
}
} else {
error "punk::console::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset"
error "punk::console::local::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset"
}
}
proc titleget {} {
@ -1306,12 +1308,12 @@ namespace eval punk::console {
if {![catch {twapi::get_console_title} result]} {
return $result
} else {
error "punk::console::titleset failed to set title - ensure twapi is available"
error "punk::console::local::titleset failed to set title - ensure twapi is available"
}
} else {
#titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title
# won't work on all platforms/terminals - but may be worth implementing
error "punk::console::titleget has no local mechanism to get the window title on this platform."
# won't work on all platforms/terminals - but may be worth implementing (for overtype::renderspace / frames etc)
error "punk::console::local::titleget has no local mechanism to get the window title on this platform."
}
}
}
@ -1327,7 +1329,7 @@ namespace eval punk::console {
if { $ansi_wanted <= 0} {
punk::console::local::titleset $windowtitle
} else {
tailcall ansi::titleset $windowtitle
ansi::titleset $windowtitle
}
}
#no known pure-ansi solution
@ -1486,8 +1488,6 @@ namespace eval punk::console {
namespace import ansi::insert_lines
namespace import ansi::delete_lines
interp alias {} smcup {} ::punk::console::enable_alt_screen
interp alias {} rmcup {} ::punk::console::disable_alt_screen
#experimental
proc rhs_prompt {col text} {
@ -1881,12 +1881,6 @@ namespace eval punk::console {
interp alias {} colour {} punk::console::colour
interp alias {} ansi {} punk::console::ansi
interp alias {} color {} punk::console::colour
interp alias {} a+ {} punk::console::code_a+
interp alias {} a {} punk::console::code_a
interp alias {} a? {} punk::console::code_a?

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

@ -1561,7 +1561,8 @@ tcl::namespace::eval punk::ns {
#set name [string trim $name :]
#set origin [namespace origin ${upns}::$name]
set origin [nseval $targetns [list ::namespace origin $name]]
set origin [nseval $targetns [list ::namespace origin $name]]
set resolved [nseval $targetns [list ::namespace which $name]]
#An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases!
if {$origin ni [info procs $origin]} {
@ -1613,7 +1614,8 @@ tcl::namespace::eval punk::ns {
}
lappend argl $a
}
list proc [nsjoin ${targetns} $name] $argl $body
#list proc [nsjoin ${targetns} $name] $argl $body
list proc $resolved $argl $body
}

BIN
src/bootsupport/modules/test/tomlish-1.1.1.tm

Binary file not shown.

37
src/bootsupport/modules/textblock-0.1.1.tm

@ -4041,6 +4041,9 @@ tcl::namespace::eval textblock {
(default 0 if no existing -table supplied)"
-table -default "" -type string -help "existing table object to use"
-headers -default "" -help "list of header values. Must match number of columns"
-show_header -default "" -help "Whether to show a header row.
Leave as empty string for unspecified/automatic,
in which case it will display only if -headers list was supplied."
-action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied
if append is chosen the new values will always start at the first column"
-columns -default "" -type integer -help "Number of table columns
@ -4101,11 +4104,34 @@ tcl::namespace::eval textblock {
}
} else {
set is_new_table 1
set headers {}
if {[tcl::dict::get $opts -headers] ne ""} {
set headers [dict get $opts -headers]
if {[tcl::dict::get $opts -show_header] eq ""} {
set show_header 1
} else {
set show_header [tcl::dict::get $opts -show_header]
}
} else {
if {[tcl::dict::get $opts -show_header] eq ""} {
set show_header 0
} else {
set show_header [tcl::dict::get $opts -show_header]
}
}
if {[tcl::string::is integer -strict $opt_columns]} {
set cols $opt_columns
if {[llength $headers] && $cols != [llength $headers]} {
error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $headers])"
}
} else {
#review
set cols 2 ;#seems a reasonable default
if {[llength $headers]} {
set cols [llength $headers]
} else {
set cols 2 ;#seems a reasonable default
}
}
#defaults for new table only
if {[tcl::dict::get $opts -frametype] eq ""} {
@ -4123,15 +4149,6 @@ tcl::namespace::eval textblock {
if {[tcl::dict::get $opts -show_hseps] eq ""} {
tcl::dict::set opts -show_hseps 0
}
set headers {}
set show_header 0
if {[tcl::dict::get $opts -headers] ne ""} {
set headers [dict get $opts -headers]
if {[llength $headers] ne $cols} {
error "list_as_table number of headers ([llength $headers]) must match number of columns ($cols)"
}
set show_header 1
}
set t [textblock::class::table new\
-show_header $show_header\

3357
src/bootsupport/modules/tomlish-1.1.1.tm

File diff suppressed because it is too large Load Diff

18
src/modules/punk/aliascore-999999.0a1.0.tm

@ -102,6 +102,8 @@ tcl::namespace::eval punk::aliascore {
variable aliases
#use absolute ns ie must be prefixed with ::
#single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased
#functions must be in export list of their source namespace
set aliases [tcl::dict::create\
tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\
@ -109,11 +111,23 @@ tcl::namespace::eval punk::aliascore {
linelist ::punk::lib::linelist\
linesort ::punk::lib::linesort\
pdict ::punk::lib::pdict\
plist [list ::punk::lib::pdict -roottype list]\
showlist [list ::punk::lib::showdict -roottype list]\
plist {::punk::lib::pdict -roottype list}\
showlist {::punk::lib::showdict -roottype list}\
showdict ::punk::lib::showdict\
ansistrip ::punk::ansi::ansistrip\
stripansi ::punk::ansi::ansistrip\
ansiwrap ::punk::ansi::ansiwrap\
colour ::punk::console::colour\
ansi ::punk::console::ansi\
color ::punk::console::colour\
a+ ::punk::console::code_a+\
A+ {::punk::console::code_a+ forcecolour}\
a ::punk::console::code_a\
A {::punk::console::code_a forcecolour}\
a? ::punk::console::code_a?\
A? {::punk::console::code_a? forcecolor}\
smcup ::punk::console::enable_alt_screen\
rmcup ::punk::console::disable_alt_screen\
]
#*** !doctools

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

@ -413,6 +413,7 @@ tcl::namespace::eval punk::ansi {
tcl::namespace::export\
{a?} {a+} a \
ansistring\
ansiwrap\
convert*\
clear*\
cursor_*\
@ -722,77 +723,11 @@ tcl::namespace::eval punk::ansi {
#candidate for zig/c implementation?
proc stripansi2 {text} {
set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters
join [::punk::ansi::ta::split_at_codes $text] ""
}
proc stripansi1 {text} {
#todo - character set selection - SS2 SS3 - how are they terminated? REVIEW
variable escape_terminals ;#dict
variable ::punk::ansi::ta::standalone_code_map ;#map to empty string
set text [convert_g0 $text]
set text [tcl::string::map $standalone_code_map $text]
#e.g standalone 2 byte and 3 byte VT100(?) sequences - some of these work in wezterm
#\x1b#3 double-height letters top half
#\x1b#4 double-height letters bottom half
#\x1b#5 single-width line
#\x1b#6 double-width line
#\x1b#8 dec test fill screen
#we process char by char - line-endings whether \r\n or \n should be processed as per any other character.
#Theoretically line endings can occur within an ST payload (review e.g title?)
#ecma standard says: The character string following may consist of any bit combination, except those representing SOS or STRING TERMINATOR (ST)
set inputlist [split $text ""]
set outputlist [list]
set in_escapesequence 0
#assumption - text already 'rendered' - ie no cursor movement controls . (what about backspace and lone carriage returns - they are horizontal cursor movements)
set i 0
foreach u $inputlist {
set v [lindex $inputlist $i+1]
set uv ${u}${v}
if {$in_escapesequence eq "2b"} {
#2nd byte - done.
set in_escapesequence 0
} elseif {$in_escapesequence != 0} {
set endseq [tcl::dict::get $escape_terminals $in_escapesequence]
if {$u in $endseq} {
set in_escapesequence 0
} elseif {$uv in $endseq} {
set in_escapesequence 2b ;#flag next byte as last in sequence
}
} else {
#handle both 7-bit and 8-bit CSI and OSC
if {[regexp {^(?:\033\[|\u009b)} $uv]} {
set in_escapesequence CSI
} elseif {[regexp {^(?:\033\]|\u009d)} $uv]} {
set in_escapesequence OSC
} elseif {[regexp {^(?:\033P|\u0090)} $uv]} {
set in_escapesequence DCS
} elseif {[regexp {^(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)} $uv]} {
#SOS,PM,APC - all terminated with ST
set in_escapesequence MISC
} else {
lappend outputlist $u
}
}
incr i
}
return [join $outputlist ""]
}
#review - what happens when no terminator?
#todo - map other character sets to unicode equivs? There seems to be little support for other than the DEC special graphics set.. ISO2022 character switching not widely supported - may be best considered deprecated(?)
# convert esc(0 -> esc(B graphics sequences to single char unicode equivalents e.g box drawing set
@ -2029,7 +1964,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#[para]Return an ansi string representing a table of codes and a panel showing the colours
variable SGR_setting_map
variable SGR_colour_map
set fcposn [lsearch $args "forcecol*"]
set fcposn [lsearch $args "force*"]
set fc ""
set opt_forcecolour 0
if {$fcposn >= 0} {
@ -2409,7 +2344,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything.
set forcecolour 0
set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour
set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour
if {$fcpos >= 0} {
set forcecolour 1
set args [lremove $args $fcpos]
@ -2767,7 +2702,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything.
set forcecolour 0
set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour
set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour
if {$fcpos >=0} {
set forcecolour 1
set args [lremove $args $fcpos]
@ -3199,6 +3134,16 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
return $out
}
proc move_emitblock {row col textblock} {
#*** !doctools
#[call [fun move_emitblock] [arg row] [arg col] [arg textblock]]
set commands ""
foreach ln [split $textblock \n] {
append commands [punk::ansi::move_emit $row $col $ln]
incr row
}
return $commands
}
proc move_forward {{n 1}} {
#*** !doctools
#[call [fun move_forward] [arg n]]
@ -3315,18 +3260,90 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
#Alt screen buffer
#Alt screen buffer - smcup/rmcup ti/te
#Note \x1b\[?47h doesn't work at all in some terminals (e.g alacritty,cmd on windows and reportedly kitty)
#It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals.
#see: https://xn--rpa.cc/irl/term.html
#1049 (introduced by xterm in 1998?) considered the more modern version?
#1047,1048,1049 xterm private modes are 'composite' control sequences as replacement for original 47 sequence
#1049 - includes save cursor,switch to alt screen, clear screen
#e.g ? (below example not known to be exactly what 1049 does - but it's something similar)
#SMCUP
# \x1b7 (save cursor)
# \x1b\[?47h (switch)
# \x1b\[2J (clear screen)
#RMCUP
# \x1b\[?47l (switch back)
# \x1b8 (restore cursor)
#1047 - clear screen on the way out (ony if actually on alt screen)
proc enable_alt_screen {} {
#tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen?
#\x1b\[?1049h ;#xterm
return \x1b\[?47h
return \x1b\[?1049h
}
proc disable_alt_screen {} {
#tput rmcup outputs \x1b\[?1049l\x1b\[23\;0\;0t]
#\x1b\[?1049l
return \x1b\[?1049l
}
#47 - less widely supported(?) doesn't restore cursor or clear alt screen
proc enable_alt_screen2 {} {
return \x1b\[?47h
}
proc disable_alt_screen2 {} {
return \x1b\[?47l
}
proc term_colour_fg {colour} {
return "\x1b\]10\;$colour\x1b\\"
}
proc term_color_fg {colour} {
return "\x1b\]10\;$colour\x1b\\"
}
proc term_colour_bg {colour} {
return "\x1b\]11\;$colour\x1b\\"
}
proc term_color_bg {colour} {
return "\x1b\]11\;$colour\x1b\\"
}
proc term_colour_cursor {colour} {
return "\x1b\]12\;$colour\x1b\\"
}
proc term_color_cursor {colour} {
return "\x1b\]12\;$colour\x1b\\"
}
proc term_colour_pointer_fg {colour} {
return "\x1b\]13\;$colour\x1b\\"
}
proc term_color_pointer_fg {colour} {
return "\x1b\]13\;$colour\x1b\\"
}
proc term_colour_pointer_bg {colour} {
return "\x1b\]14\;$colour\x1b\\"
}
proc term_color_pointer_bg {colour} {
return "\x1b\]14\;$colour\x1b\\"
}
#15,16 tektronix fg, tektronix bg ???
proc term_colour_highlight_bg {colour} {
return "\x1b\]17\;$colour\x1b\\"
}
proc term_color_highlight_bg {colour} {
return "\x1b\]17\;$colour\x1b\\"
}
#18 tektronix cursor colour ???
proc term_colour_highlight_fg {colour} {
return "\x1b\]19\;$colour\x1b\\"
}
proc term_color_highlight_fg {colour} {
return "\x1b\]19\;$colour\x1b\\"
}
#22 pointer shape - there are other methods too - not known to work on windows terminal based VTs - review
proc term_colour_reset {} {
return "\x1b\]104\;\x1b\\"
}
proc term_color_reset {} {
return "\x1b\]104\;\x1b\\"
}
# -- --- ---
proc erase_line {} {
@ -4398,6 +4415,10 @@ tcl::namespace::eval punk::ansi::ta {
variable re_ansi_detect_open
expr {[regexp $re_ansi_detect_open $text]}
}
proc detect_st_open {text} {
variable re_ST_open
expr {[regexp $re_ST_open $text]}
}
#not in perl ta
proc detect_csi {text} {
@ -4672,7 +4693,8 @@ tcl::namespace::eval punk::ansi::class {
}
oo::class create base_renderer {
variable o_width
variable o_wrap o_overflow o_appendlines o_looplimit
variable o_autowrap_mode
variable o_overflow o_appendlines o_looplimit
variable o_cursor_column o_cursor_row
#variable o_render_index ;#index of input (from_ansistring) grapheme/ansi-code that *has* been rendered
@ -4690,25 +4712,33 @@ tcl::namespace::eval punk::ansi::class {
}
tcl::namespace::path $nspath
#-- --
if {[llength $args] < 2} {
error {usage: ?-width <int>? ?-wrap [1|0]? ?-overflow [1|0]? from_ansistring to_ansistring}
if {[llength $args] < 1} {
error {usage: ?-width <int>? ?-height <height>? ?-autowrap_mode [1|0]? ?-overflow [1|0]? from_ansistring}
}
lassign [lrange $args end-1 end] from_ansistring to_ansistring
#lassign [lrange $args end-1 end] from_ansistring to_ansistring
set from_ansistring [lindex $args end]
set opts [tcl::dict::create\
-width \uFFEF\
-wrap 1\
-overflow 0\
-appendlines 1\
-looplimit 15000\
-experimental {}\
-cursor_column 1\
-cursor_row 1\
-width \uFFEF\
-height \uFFEF\
-overflow 0\
-appendlines 1\
-looplimit 15000\
-experimental {}\
-cursor_column 1\
-cursor_row 1\
-insert_mode 0\
-autowrap_mode 1\
-initial_ansistring ""\
]
puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring"
set argsflags [lrange $args 0 end-2]
foreach {k v} $argsflags {
switch -- $k {
-width - -wrap - -overflow - -appendlines - -looplimit - -experimental {
-width - -height -
-overflow - -appendlines - -looplimit - -experimental -
-autowrap_mode -
-insert_mode -
-initial_ansistring {
tcl::dict::set opts $k $v
}
default {
@ -4717,8 +4747,19 @@ tcl::namespace::eval punk::ansi::class {
}
}
}
set initial_ansistring [tcl::dict::get $opts -initial_ansistring]
if {$initial_ansistring eq ""} {
set to_ansistring [punk::ansi::class::class_ansistring new ""]
} else {
#todo - verify obj vs raw string
set to_ansistring $initial_ansistring
}
puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring"
set o_width [tcl::dict::get $opts -width]
set o_wrap [tcl::dict::get $opts -wrap]
set o_height [tcl::dict::get $opts -height]
set o_autowrap_mode [tcl::dict::get $opts -autowrap_mode]
set o_insert_mode [tcl::dict::get $opts -insert_mode]
set o_overflow [tcl::dict::get $opts -overflow]
set o_appendlines [tcl::dict::get $opts -appendlines]
set o_looplimit [tcl::dict::get $opts -looplimit]
@ -4736,6 +4777,9 @@ tcl::namespace::eval punk::ansi::class {
method eval_in {script} {
eval $script
}
method renderbuf {} {
return $o_to_ansistring
}
method cursor_column {{col ""}} {
if {$col eq ""} {
return $o_cursor_column
@ -4755,6 +4799,12 @@ tcl::namespace::eval punk::ansi::class {
set o_cursor_row $row
}
#set/query cursor state
method cursor_state {args} {
lassign $args r c
return [dict create row [my cursor_row $r] column [my cursor_column $c]]
}
#consider scroll area
#we need to render to something with a concept of viewport, offscreen above,below,left,right?
method rendernext {} {
@ -4834,7 +4884,8 @@ tcl::namespace::eval punk::ansi::class {
#set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext]
}
}
#renderspace equivalent? channel based?
#todo
$o_to_ansistring append $newtext
return [tcl::dict::create type $type_rendered rendercount $rendercount start_count_unrendered $start_elements_unrendered end_count_unrendered $end_elements_unrendered]
@ -4960,11 +5011,10 @@ tcl::namespace::eval punk::ansi::class {
if {$o_renderer ne ""} {
append result \n " renderer obj: $o_renderer"
append result \n " renderer class: [info object class $o_renderer]"
}
if {$o_renderout ne ""} {
append result \n " render target ansistring: $o_renderout"
append result \n " render target has ansi : [$o_renderout has_ansi]"
append result \n " render target count : [$o_renderout count]"
set renderstring [$o_renderer renderbuf]
append result \n " render target ansistring: $renderstring"
append result \n " render target has ansi : [$renderstring has_ansi]"
append result \n " render target count : [$renderstring count]"
}
if {$verbose} {
append result \n "ansisplits listing"
@ -5052,7 +5102,8 @@ tcl::namespace::eval punk::ansi::class {
}
method strippedlength {} {
if {![llength $o_ansisplits]} {my MakeSplit}
#review
return [string length [join $o_ptlist ""]]
}
#returns the ansiless string - doesn't affect the stored state other than initialising it's internal state if it wasn't already
method stripped {} {
@ -5119,10 +5170,9 @@ tcl::namespace::eval punk::ansi::class {
if {$rtype ni $rtypes} {
error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)"
}
if {$o_renderout eq ""} {
#tell ansistring that it's a renderbuf for another ansistring? point it to the renderer or the parent ansistring?
set o_renderout [punk::ansi::class::class_ansistring new ""]
}
#if {$o_renderout eq ""} {
# set o_renderout [punk::ansi::class::class_ansistring new ""]
#}
if {$o_renderer ne ""} {
set oinfo [info object class $o_renderer]
set tail [tcl::namespace::tail $oinfo]
@ -5130,13 +5180,15 @@ tcl::namespace::eval punk::ansi::class {
if {$rtype ne $currenttype} {
puts "switch rendertype from $currenttype to $rtype - destroying renderer and creating a new one"
$o_renderer destroy ;#what happens to data in target ansistring obj? when does it make sense to keep output and keep rendering vs clearing?
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
#set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]]
} else {
return $currenttype
}
} else {
puts "creating first renderer"
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
#set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]]
}
}
#--- progressive rendering buffer - another ansistring object
@ -5149,10 +5201,13 @@ tcl::namespace::eval punk::ansi::class {
return $o_renderwidth
}
#re-render if needed?
puts stderr "renderwidth todo? re-render?"
set o_renderwidth $rw
}
method renderer {} {
return $o_renderer
}
method render_state {} {
#? report state of render.. we will primarily be using plaintext/ansisequence as the chunk/operation boundary
#but - as we can append char sequences directly to the tail split - it's not enough to track which split element we have rendered - but we also need how many graphemes or code sequences we are into the last split.
@ -5160,10 +5215,36 @@ tcl::namespace::eval punk::ansi::class {
}
method renderbuf {} {
#get the underlying renderobj - if any
return $o_renderout ;#also class_ansistring
#return $o_renderout ;#also class_ansistring
return [$o_renderer renderbuf]
}
method render {} {
method render {{maxgraphemes ""}} {
#full render - return buffer ansistring
set do_render 1
set grapheme_count 0
set other_count 0
if {$maxgraphemes eq ""} {
while {$do_render} {
set rendition [my rendernext]
set do_render [dict get $rendition rendercount]
if {[dict get $rendition type] eq "g"} {
incr grapheme_count $do_render
} else {
incr other_count $do_render
}
}
} else {
while {$do_render && $grapheme_count <= $maxgraphemes} {
set rendition [my rendernext]
set do_render [dict get $rendition rendercount]
if {[dict get $rendition type] eq "g"} {
incr grapheme_count $do_render
} else {
incr other_count $do_render
}
}
}
return [dict create graphemes $grapheme_count other $other_count]
}
method rendernext {} {
#render next available pt/code chunk only - not to end of available input
@ -5198,6 +5279,13 @@ tcl::namespace::eval punk::ansi::class {
#i.e a 'rendered' ANSI string should contain just ANSI SGR character attributes and linefeeds for rows
#Knowing which is which can be helpful as far as use of any methods which use the concepts of terminal row/column
#like Tcl's append class_ansistring append returns the result directly - which for ANSI - can be inconvenient in the terminal
#class_ansistring append_string is a convenience wrapper to avoid returning the raw result
method append_string {args} {
my append {*}$args
return
}
#analagous to Tcl string append
#MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient
method append {args} {
@ -5369,7 +5457,7 @@ tcl::namespace::eval punk::ansi::class {
}
#method append_and_render - append and render up to end of appended data at same time
#method append_and_render? - append and render up to end of appended data at same time
method view {args} {
if {$o_string eq ""} {

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

@ -20,12 +20,14 @@
#*** !doctools
#[manpage_begin shellspy_module_punk::blockletter 0 999999.0a1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[titledesc {punk::blockletter frame-based large lettering test/logo}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require punk::blockletter]
#[keywords module]
#[description]
#[para] -
#[para] This is primarily designed to test large lettering using the block2 frametype which requires the right font support
#[para] More reasonably sized block-lettering could be obtained using unicode half-blocks instead - but that doesn't allow the frame outline effect that block2 gives.
#[para] Individual blocks have a minimum width of 4 columns and a minimum height of 2 rows (smallest element that can be fully framed)
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++

19
src/modules/punk/config-0.1.tm

@ -60,12 +60,19 @@ tcl::namespace::eval punk::config {
}
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run
#optional channel transforms on stdout/stderr.
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands
#If no distinction necessary - should use default_color_<chan>
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation.
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default
set default_color_stdout ""
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc)
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful.
#set default_color_stderr "red bold"
#set default_color_stderr "web-lightsalmon"
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive
set default_color_stderr_repl "" ;#during repl call only
set homedir ""
if {[catch {
@ -132,7 +139,9 @@ tcl::namespace::eval punk::config {
configset ".punkshell"\
scriptlib $default_scriptlib\
color_stdout $default_color_stdout\
color_stdout_repl $default_color_stdout_repl\
color_stderr $default_color_stderr\
color_stderr_repl $default_color_stderr_repl\
logfile_stdout $default_logfile_stdout\
logfile_stderr $default_logfile_stderr\
logfile_active 0\
@ -172,9 +181,11 @@ tcl::namespace::eval punk::config {
PUNK_CONFIGSET {type string}\
PUNK_SCRIPTLIB {type string}\
PUNK_AUTO_EXEC_MECHANISM {type string}\
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\
PUNK_COLOR_STDERR {type string}\
PUNK_COLOR_STDOUT {type string}\
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\
PUNK_LOGFILE_STDOUT {type string}\
PUNK_LOGFILE_STDERR {type string}\
PUNK_LOGFILE_ACTIVE {type string}\

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

@ -864,6 +864,7 @@ namespace eval punk::console {
#Turning ansi off only stops new ansi being generated - but what about codes stored in configurations of existing elements such as tables/frames?
#It will stop underlines/bold/reverse as well as SGR colours
#what about ansi movement codes etc?
#we already have colour on|off which disables SGR codes in a+ etc as well as stderr/stdout channel transforms
proc ansi {{onoff {}}} {
variable ansi_wanted
if {[string length $onoff]} {
@ -891,6 +892,7 @@ namespace eval punk::console {
}
}
catch {punk::repl::reset_prompt}
puts stderr "::punk::console::ansi - use 'colour' command to turn SGR codes on/off"
return [expr {$ansi_wanted}]
}
@ -1295,10 +1297,10 @@ namespace eval punk::console {
if {![catch {twapi::set_console_title $windowtitle} result]} {
return $windowtitle
} else {
error "punk::console::titleset failed to set title - try punk::console::ansi::titleset"
error "punk::console::local::titleset failed to set title - try punk::console::ansi::titleset"
}
} else {
error "punk::console::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset"
error "punk::console::local::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset"
}
}
proc titleget {} {
@ -1306,12 +1308,12 @@ namespace eval punk::console {
if {![catch {twapi::get_console_title} result]} {
return $result
} else {
error "punk::console::titleset failed to set title - ensure twapi is available"
error "punk::console::local::titleset failed to set title - ensure twapi is available"
}
} else {
#titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title
# won't work on all platforms/terminals - but may be worth implementing
error "punk::console::titleget has no local mechanism to get the window title on this platform."
# won't work on all platforms/terminals - but may be worth implementing (for overtype::renderspace / frames etc)
error "punk::console::local::titleget has no local mechanism to get the window title on this platform."
}
}
}
@ -1327,7 +1329,7 @@ namespace eval punk::console {
if { $ansi_wanted <= 0} {
punk::console::local::titleset $windowtitle
} else {
tailcall ansi::titleset $windowtitle
ansi::titleset $windowtitle
}
}
#no known pure-ansi solution
@ -1486,8 +1488,6 @@ namespace eval punk::console {
namespace import ansi::insert_lines
namespace import ansi::delete_lines
interp alias {} smcup {} ::punk::console::enable_alt_screen
interp alias {} rmcup {} ::punk::console::disable_alt_screen
#experimental
proc rhs_prompt {col text} {
@ -1881,12 +1881,6 @@ namespace eval punk::console {
interp alias {} colour {} punk::console::colour
interp alias {} ansi {} punk::console::ansi
interp alias {} color {} punk::console::colour
interp alias {} a+ {} punk::console::code_a+
interp alias {} a {} punk::console::code_a
interp alias {} a? {} punk::console::code_a?

5
src/modules/punk/nav/fs-999999.0a1.0.tm

@ -219,7 +219,8 @@ tcl::namespace::eval punk::nav::fs {
}
if {[punk::nav::fs::system::codethread_is_running]} {
if {[llength [info commands ::punk::console::titleset]]} {
::punk::console::titleset [lrange $result 1 end]
#if ansi is off - punk::console::titleset will try 'local' api method - which can fail
catch {::punk::console::titleset [lrange $result 1 end]}
}
}
if {[string match //zipfs:/* $location]} {
@ -489,7 +490,7 @@ tcl::namespace::eval punk::nav::fs {
tsv::lappend repl runchunks-$repl_runid {*}$chunklist
}
if {[llength [info commands ::punk::console::titleset]]} {
::punk::console::titleset [lrange $result 1 end] ;#strip location key
catch {::punk::console::titleset [lrange $result 1 end]} ;#strip location key
}
}
if {$repl_runid == 0} {

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

@ -1561,7 +1561,8 @@ tcl::namespace::eval punk::ns {
#set name [string trim $name :]
#set origin [namespace origin ${upns}::$name]
set origin [nseval $targetns [list ::namespace origin $name]]
set origin [nseval $targetns [list ::namespace origin $name]]
set resolved [nseval $targetns [list ::namespace which $name]]
#An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases!
if {$origin ni [info procs $origin]} {
@ -1613,7 +1614,8 @@ tcl::namespace::eval punk::ns {
}
lappend argl $a
}
list proc [nsjoin ${targetns} $name] $argl $body
#list proc [nsjoin ${targetns} $name] $argl $body
list proc $resolved $argl $body
}

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

@ -31,7 +31,9 @@ package require shellfilter
#package require punk
package require punk::lib
package require punk::aliascore
punk::aliascore::init
if {[catch {punk::aliascore::init} errM]} {
puts stderr "punk::aliascore::init error: $errM"
}
package require punk::config
package require punk::ns
package require punk::ansi
@ -2576,8 +2578,41 @@ namespace eval repl {
}
}
proc colour args {
thread::send %replthread% [list punk::console::colour {*}$args]
interp eval code [list punk::console::colour {*}$args]
set colour_state [thread::send %replthread% [list punk::console::colour]]
if {[llength $args]} {
#colour call was not a query
set new_state [thread::send %replthread% [list punk::console::colour {*}$args]]
if {[expr {$new_state}] ne [expr {$colour_state}]} {
interp eval code [list punk::console::colour {*}$args] ;#align code interp's view of colour state with repl thread
interp eval code [string map [list <cstate> $new_state] {
#adjust channel transform stack
set docolour [expr {<cstate>}]
if {!$docolour} {
set s [lindex $::codeinterp::outstack end]
if {$s ne ""} {
shellfilter::stack::remove stdout $s
}
set s [lindex $::codeinterp::errstack end]
if {$s ne ""} {
shellfilter::stack::remove stderr $s
}
} else {
set running_config $::punk::config::running
if {[string length [dict get $running_config color_stdout]]} {
lappend ::codeinterp::outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]]
}
if {[string length [dict get $running_config color_stderr]]} {
lappend ::codeinterp::errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]]
}
}
}]
}
return $new_state
} else {
return $colour_state
}
#todo - add/remove shellfilter stacked ansiwrap
}
proc mode args {
thread::send %replthread% [list punk::console::mode {*}$args]
@ -2686,6 +2721,10 @@ namespace eval repl {
#review argv0,argv,argc
interp eval code {
namespace eval ::codeinterp {
variable errstack {}
variable outstack {}
}
set ::argv0 %argv0%
set ::auto_path %autopath%
#puts stdout "safe interp"
@ -2724,6 +2763,10 @@ namespace eval repl {
set ::auto_path %autopath%
#puts stdout "safe interp"
#flush stdout
namespace eval ::codeinterp {
variable errstack {}
variable outstack {}
}
}
interp eval code [list set ::tcl_platform(os) $::tcl_platform(os)]
interp eval code [list set ::tcl_platform(osVersion) $::tcl_platform(osVersion)]
@ -2775,7 +2818,11 @@ namespace eval repl {
set ::auto_path %autopath%
tcl::tm::remove {*}[tcl::tm::list]
tcl::tm::add {*}[lreverse %tmlist%]
#puts "-->[chan names]"
puts "code interp chan names-->[chan names]"
namespace eval ::codeinterp {
variable errstack {}
variable outstack {}
}
# -- ---
#review
@ -2805,11 +2852,22 @@ namespace eval repl {
#catch {package require packageTrace}
package require punk
package require shellrun
package require shellfilter
set running_config $::punk::config::running
if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} {
lappend ::codeinterp::errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]]
}
if {[string length [dict get $running_config color_stdout]] && [punk::console::colour]} {
lappend ::codeinterp::outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]]
}
package require textblock
} errM]} {
puts stderr "========================"
puts stderr "code interp error:"
puts stderr $errM
puts stderr $::errorInfo
puts stderr "========================"
error "$errM"
}

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

@ -151,16 +151,19 @@ tcl::namespace::eval punk::repl::codethread {
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread"
return
}
set outstack [list]
set errstack [list]
upvar ::punk::config::running running_config
if {[string length [dict get $running_config color_stdout]] && [punk::console::colour]} {
lappend outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]]
if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} {
lappend outstack [interp eval code [list shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]]
}
lappend outstack [shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]
if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} {
lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]]
#lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]]
lappend outstack [interp eval code [list shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]]
if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} {
lappend errstack [interp eval code [list shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]]
# #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]]
}
lappend errstack [shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]
lappend errstack [interp eval code [list shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]]
#an experiment
#set errhandle [shellfilter::stack::item_tophandle stderr]
@ -177,8 +180,8 @@ tcl::namespace::eval punk::repl::codethread {
#interp transfer code $errhandle ""
#flush $errhandle
set lastoutchar [string index [punk::ansi::ansistrip $output_stdout] end]
set lasterrchar [string index [punk::ansi::ansistrip $output_stderr] end]
set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end]
set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end]
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]"
set tid [thread::id]
@ -188,11 +191,12 @@ tcl::namespace::eval punk::repl::codethread {
tsv::set codethread_$tid errorcode $::errorCode
#only remove from shellfilter::stack the items we added to stack in this function
foreach s [lreverse $outstack] {
shellfilter::stack::remove stdout $s
interp eval code [list shellfilter::stack::remove stdout $s]
}
foreach s [lreverse $errstack] {
shellfilter::stack::remove stderr $s
interp eval code [list shellfilter::stack::remove stderr $s]
}
thread::cond notify $replthread_cond
}

296
src/modules/punk/rest-999999.0a1.0.tm

@ -0,0 +1,296 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) DKF (based on DKF's REST client support class)
# (C) 2024 JMN - packaging/possible mods
#
# @@ Meta Begin
# Application punk::rest 999999.0a1.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::rest 0 999999.0a1.0]
#[copyright "2024"]
#[titledesc {punk::rest}] [comment {-- Name section and table of contents description --}]
#[moddesc {experimental rest}] [comment {-- Description at end of page heading --}]
#[require punk::rest]
#[keywords module rest http]
#[description]
#[para] Experimental *basic rest as wrapper over http lib - use tcllib's rest package for a more complete implementation of a rest client
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::rest
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::rest
#[list_begin itemized]
package require Tcl 8.6-
package require http
#*** !doctools
#[item] [package {Tcl 8.6}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::rest::class {
#*** !doctools
#[subsection {Namespace punk::rest::class}]
#[para] class definitions
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::rest {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
#*** !doctools
#[subsection {Namespace punk::rest}]
#[para] Core API functions for punk::rest
#[list_begin definitions]
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1
# #[para] Arguments:
# # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n.
# # [list_end]
# return "ok"
#}
set objname [namespace current]::matrixchain
if {$objname ni [info commands $objname]} {
# Support class for RESTful web services.
# This wraps up the http package to make everything appear nicer.
oo::class create CLIENT {
variable base wadls acceptedmimetypestack
constructor baseURL {
set base $baseURL
my LogWADL $baseURL
}
# TODO: Cookies!
method ExtractError {tok} {
return [http::code $tok],[http::data $tok]
}
method OnRedirect {tok location} {
upvar 1 url url
set url $location
# By default, GET doesn't follow redirects; the next line would
# change that...
#return -code continue
set where $location
my LogWADL $where
if {[string equal -length [string length $base/] $location $base/]} {
set where [string range $where [string length $base/] end]
return -level 2 [split $where /]
}
return -level 2 $where
}
method LogWADL url {
return;# do nothing
set tok [http::geturl $url?_wadl]
set w [http::data $tok]
http::cleanup $tok
if {![info exist wadls($w)]} {
set wadls($w) 1
puts stderr $w
}
}
method PushAcceptedMimeTypes args {
lappend acceptedmimetypestack [http::config -accept]
http::config -accept [join $args ", "]
return
}
method PopAcceptedMimeTypes {} {
set old [lindex $acceptedmimetypestack end]
set acceptedmimetypestack [lrange $acceptedmimetypestack 0 end-1]
http::config -accept $old
return
}
method DoRequest {method url {type ""} {value ""}} {
for {set reqs 0} {$reqs < 5} {incr reqs} {
if {[info exists tok]} {
http::cleanup $tok
}
set tok [http::geturl $url -method $method -type $type -query $value]
if {[http::ncode $tok] > 399} {
set msg [my ExtractError $tok]
http::cleanup $tok
return -code error $msg
} elseif {[http::ncode $tok] > 299 || [http::ncode $tok] == 201} {
set location {}
if {[catch {
set location [dict get [http::meta $tok] Location]
}]} {
http::cleanup $tok
error "missing a location header!"
}
my OnRedirect $tok $location
} else {
set s [http::data $tok]
http::cleanup $tok
return $s
}
}
error "too many redirections!"
}
method GET args {
return [my DoRequest GET $base/[join $args /]]
}
method POST {args} {
set type [lindex $args end-1]
set value [lindex $args end]
set m POST
set path [join [lrange $args 0 end-2] /]
return [my DoRequest $m $base/$path $type $value]
}
method PUT {args} {
set type [lindex $args end-1]
set value [lindex $args end]
set m PUT
set path [join [lrange $args 0 end-2] /]
return [my DoRequest $m $base/$path $type $value]
}
method DELETE args {
set m DELETE
my DoRequest $m $base/[join $args /]
return
}
export GET POST PUT DELETE
}
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::rest ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::rest::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::rest::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::rest::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::rest::system {
#*** !doctools
#[subsection {Namespace punk::rest::system}]
#[para] Internal functions that are not part of the API
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::rest [tcl::namespace::eval punk::rest {
variable pkg punk::rest
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]

3
src/modules/punk/rest-buildversion.txt

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

58
src/modules/shellfilter-0.1.9.tm

@ -654,6 +654,7 @@ namespace eval shellfilter::chan {
#detect will detect ansi SGR and gron groff and other codes
if {[punk::ansi::ta::detect $buf]} {
#split_codes_single regex faster than split_codes - but more resulting parts
#'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc)
set parts [punk::ansi::ta::split_codes_single $buf]
#process all pt/code pairs except for trailing pt
foreach {pt code} [lrange $parts 0 end-1] {
@ -725,21 +726,70 @@ namespace eval shellfilter::chan {
} else {
#puts "-->esc but no detect"
#no complete ansi codes - but at least one esc is present
if {[string first \x1b $buf] == [llength $buf]-1} {
if {[string last \x1b $buf] == [llength $buf]-1} {
#only esc is last char in buf
#puts ">>trailing-esc<<"
set o_buffered \x1b
set emit [string range $buf 0 end-1]
} else {
set emit_anyway 0
#todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer
append o_buffered $chunk
set emit ""
if {[punk::ansi::ta::detect_st_open $buf]} {
#no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms)
set st_partial_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code
#todo - configurable ST max - use 1k for now
if {$st_partial_len < 1001} {
append o_buffered $chunk
set emit ""
} else {
set emit_anyway 1
}
} else {
set possible_code_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of possible code
#most opening sequences are 1,2 or 3 chars - review?
set open_sequence_detected [punk::ansi::ta::detect_open $buf]
if {$possible_code_len > 10 && !$open_sequence_detected} {
set emit_anyway 1
} else {
#could be composite sequence with params - allow some reasonable max sequence length
#todo - configurable max sequence length
#len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies
# - allow some headroom for redundant codes when the caller didn't merge.
if {$possible_code_len < 101} {
append o_buffered $chunk
set emit ""
} else {
#allow a little more grace if we at least have an opening ansi sequence of any type..
if {$open_sequence_detected && $possible_code_len < 151} {
append o_buffered $chunk
set emit ""
} else {
set emit_anyway 1
}
}
}
}
if {$emit_anyway} {
#looked ansi-like - but we've given enough length without detecting close..
#treat as possible plain text with some esc or unrecognised ansi sequence
if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} {
set emit $o_do_colour$buf$o_do_normal
} else {
set emit $buf
}
}
}
}
} else {
#no esc
#puts stdout [a+ yellow]...[a]
set emit $buf
#test!
if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} {
set emit $o_do_colour$buf$o_do_normal
} else {
set emit $buf
}
#set emit $buf
set o_buffered ""
}
return [dict create emit $emit stacksize [llength $o_codestack]]

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

@ -4041,6 +4041,9 @@ tcl::namespace::eval textblock {
(default 0 if no existing -table supplied)"
-table -default "" -type string -help "existing table object to use"
-headers -default "" -help "list of header values. Must match number of columns"
-show_header -default "" -help "Whether to show a header row.
Leave as empty string for unspecified/automatic,
in which case it will display only if -headers list was supplied."
-action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied
if append is chosen the new values will always start at the first column"
-columns -default "" -type integer -help "Number of table columns
@ -4101,11 +4104,34 @@ tcl::namespace::eval textblock {
}
} else {
set is_new_table 1
set headers {}
if {[tcl::dict::get $opts -headers] ne ""} {
set headers [dict get $opts -headers]
if {[tcl::dict::get $opts -show_header] eq ""} {
set show_header 1
} else {
set show_header [tcl::dict::get $opts -show_header]
}
} else {
if {[tcl::dict::get $opts -show_header] eq ""} {
set show_header 0
} else {
set show_header [tcl::dict::get $opts -show_header]
}
}
if {[tcl::string::is integer -strict $opt_columns]} {
set cols $opt_columns
if {[llength $headers] && $cols != [llength $headers]} {
error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $headers])"
}
} else {
#review
set cols 2 ;#seems a reasonable default
if {[llength $headers]} {
set cols [llength $headers]
} else {
set cols 2 ;#seems a reasonable default
}
}
#defaults for new table only
if {[tcl::dict::get $opts -frametype] eq ""} {
@ -4123,15 +4149,6 @@ tcl::namespace::eval textblock {
if {[tcl::dict::get $opts -show_hseps] eq ""} {
tcl::dict::set opts -show_hseps 0
}
set headers {}
set show_header 0
if {[tcl::dict::get $opts -headers] ne ""} {
set headers [dict get $opts -headers]
if {[llength $headers] ne $cols} {
error "list_as_table number of headers ([llength $headers]) must match number of columns ($cols)"
}
set show_header 1
}
set t [textblock::class::table new\
-show_header $show_header\

4
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config

@ -6,7 +6,6 @@
set bootsupport_modules [list\
src/vendormodules cksum\
src/vendormodules modpod\
src/vendormodules natsort\
src/vendormodules overtype\
src/vendormodules oolib\
src/vendormodules http\
@ -22,6 +21,8 @@ set bootsupport_modules [list\
src/vendormodules uuid\
src/vendormodules md5\
src/vendormodules sha1\
src/vendormodules tomlish\
src/vendormodules test::tomlish\
modules punkcheck\
modules natsort\
modules punk::ansi\
@ -60,6 +61,7 @@ set bootsupport_modules [list\
modules punk::zip\
modules punk::winpath\
modules textblock\
modules natsort\
modules oolib\
]

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

@ -233,7 +233,6 @@ tcl::namespace::eval overtype {
-width \uFFEF\
-height \uFFEF\
-startcolumn 1\
-wrap 0\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
@ -243,11 +242,13 @@ tcl::namespace::eval overtype {
-exposed1 \uFFFD\
-exposed2 \uFFFD\
-experimental 0\
-cp437 1\
-cp437 0\
-looplimit \uFFEF\
-crm_mode 0\
-reverse_mode 0\
-insert_mode 0\
-wrap 0\
-info 0\
-console {stdin stdout stderr}\
]
#expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally..
@ -263,14 +264,19 @@ tcl::namespace::eval overtype {
#-ellipsis args not used if -wrap is true
foreach {k v} $argsflags {
switch -- $k {
-looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace
-looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace
- -transparent - -exposed1 - -exposed2 - -experimental
- -expand_right - -appendlines
- -reverse_mode - -crm_mode - -insert_mode
- -cp437
- -console {
- -info - -console {
tcl::dict::set opts $k $v
}
-wrap - -autowrap_mode {
#temp alias -autowrap_mode for consistency with renderline
#todo -
tcl::dict::set opts -wrap $v
}
default {
error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]"
}
@ -280,10 +286,6 @@ tcl::namespace::eval overtype {
# -- --- --- --- --- ---
#review - expand_left for RTL text?
set opt_expand_right [tcl::dict::get $opts -expand_right]
#####
# review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?.
set opt_wrap [tcl::dict::get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo)
#####
#for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line.
set opt_width [tcl::dict::get $opts -width]
set opt_height [tcl::dict::get $opts -height]
@ -298,50 +300,34 @@ tcl::namespace::eval overtype {
set opt_crm_mode [tcl::dict::get $opts -crm_mode]
set opt_reverse_mode [tcl::dict::get $opts -reverse_mode]
set opt_insert_mode [tcl::dict::get $opts -insert_mode]
#####
# review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?.
set opt_autowrap_mode [tcl::dict::get $opts -wrap]
#??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo)
#####
# -- --- --- --- --- ---
set opt_cp437 [tcl::dict::get $opts -cp437]
set opt_info [tcl::dict::get $opts -info]
#initial state for renderspace 'terminal' reset
set initial_state [dict create\
-width $opt_width\
-height $opt_height\
-crm_mode $opt_crm_mode\
-reverse_mode $opt_reverse_mode\
-insert_mode $opt_insert_mode\
-cp437 $opt_cp437\
]
# ----------------------------
# -experimental dev flag to set flags etc
# ----------------------------
set data_mode 0
set info_mode 0
set edit_mode 0
set opt_experimental [tcl::dict::get $opts -experimental]
foreach o $opt_experimental {
switch -- $o {
old_mode {
set info_mode 1
}
data_mode {
set data_mode 1
}
info_mode {
set info_mode 1
}
edit_mode {
set edit_mode 1
}
}
}
# ----------------------------
#modes
set insert_mode $opt_insert_mode ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l
set autowrap_mode $opt_wrap
set reverse_mode $opt_reverse_mode
set crm_mode $opt_crm_mode
set underblock [tcl::string::map {\r\n \n} $underblock]
@ -367,6 +353,20 @@ tcl::namespace::eval overtype {
set renderwidth $opt_width
set renderheight $opt_height
}
#initial state for renderspace 'terminal' reset
set initial_state [dict create\
renderwidth $renderwidth\
renderheight $renderheight\
crm_mode $opt_crm_mode\
reverse_mode $opt_reverse_mode\
insert_mode $opt_insert_mode\
autowrap_mode $opt_autowrap_mode\
cp437 $opt_cp437\
]
#modes
#e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l
#opt_startcolumn ?? - DECSLRM ?
set vtstate $initial_state
# -- --- --- ---
#REVIEW - do we need ansi resets in the underblock?
@ -494,50 +494,55 @@ tcl::namespace::eval overtype {
}
#review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary -
#but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l
set renderargs [list -experimental $opt_experimental\
-cp437 $opt_cp437\
-info 1\
-crm_mode $crm_mode\
-insert_mode $insert_mode\
-autowrap_mode $autowrap_mode\
-reverse_mode $reverse_mode\
-cursor_restore_attributes $cursor_saved_attributes\
-transparent $opt_transparent\
-width $renderwidth\
-exposed1 $opt_exposed1\
-exposed2 $opt_exposed2\
-expand_right $opt_expand_right\
-cursor_column $col\
-cursor_row $row\
set renderargs [list -experimental $opt_experimental\
-cp437 $opt_cp437\
-info 1\
-crm_mode [tcl::dict::get $vtstate crm_mode]\
-insert_mode [tcl::dict::get $vtstate insert_mode]\
-autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\
-reverse_mode [tcl::dict::get $vtstate reverse_mode]\
-cursor_restore_attributes $cursor_saved_attributes\
-transparent $opt_transparent\
-width [tcl::dict::get $vtstate renderwidth]\
-exposed1 $opt_exposed1\
-exposed2 $opt_exposed2\
-expand_right $opt_expand_right\
-cursor_column $col\
-cursor_row $row\
$undertext\
$overtext\
]
set LASTCALL $renderargs
set rinfo [renderline {*}$renderargs]
set instruction [tcl::dict::get $rinfo instruction]
set insert_mode [tcl::dict::get $rinfo insert_mode]
set autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;#
set reverse_mode [tcl::dict::get $rinfo reverse_mode]
set instruction [tcl::dict::get $rinfo instruction]
tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode]
tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode]
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;#
tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode]
#how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack?
# - review - the answer is probably that we don't need to - it is set/reset only during application of overtext
set crm_mode [tcl::dict::get $rinfo crm_mode]
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set overflow_right_column [tcl::dict::get $rinfo overflow_right_column]
set unapplied [tcl::dict::get $rinfo unapplied]
set unapplied_list [tcl::dict::get $rinfo unapplied_list]
set post_render_col [tcl::dict::get $rinfo cursor_column]
set post_render_row [tcl::dict::get $rinfo cursor_row]
set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position]
set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes]
set visualwidth [tcl::dict::get $rinfo visualwidth]
set insert_lines_above [tcl::dict::get $rinfo insert_lines_above]
set insert_lines_below [tcl::dict::get $rinfo insert_lines_below]
tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay]
#Note carefully the difference betw overflow_right and unapplied.
#overflow_right may need to be included in next run before the unapplied data
#overflow_right most commonly has data when in insert_mode
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set overflow_right_column [tcl::dict::get $rinfo overflow_right_column]
set unapplied [tcl::dict::get $rinfo unapplied]
set unapplied_list [tcl::dict::get $rinfo unapplied_list]
set post_render_col [tcl::dict::get $rinfo cursor_column]
set post_render_row [tcl::dict::get $rinfo cursor_row]
set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position]
set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes]
set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line
set insert_lines_above [tcl::dict::get $rinfo insert_lines_above]
set insert_lines_below [tcl::dict::get $rinfo insert_lines_below]
tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay]
#lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay]
set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]
if {0 && $reverse_mode} {
if {0 && [tcl::dict::get $vtstate reverse_mode]} {
#test branch - todo - prune
puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered"
#review
@ -593,19 +598,29 @@ tcl::namespace::eval overtype {
#todo - handle potential insertion mode as above for cursor restore?
#keeping separate branches for debugging - review and merge as appropriate when stable
tcl::dict::incr instruction_stats $instruction
switch -- $instruction {
set instruction_type [lindex $instruction 0] ;#some instructions have params
tcl::dict::incr instruction_stats $instruction_type
switch -- $instruction_type {
reset {
#reset the 'renderspace terminal' (not underlying terminal)
set row 1
set col 1
set vtstate [tcl::dict::merge $vtstate $initial_state]
#todo - clear screen
}
{} {
#end of supplied line input
#lf included in data
set row $post_render_row
set col $post_render_col
if {![llength $unapplied_list]} {
if {$overflow_right ne ""} {
incr row
}
} else {
puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)"
}
set col $opt_startcolumn
}
up {
@ -708,17 +723,18 @@ tcl::namespace::eval overtype {
puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]"
set sub_info [overtype::renderline -info 1\
-width $renderwidth\
-insert_mode $insert_mode\
-autowrap_mode $autowrap_mode\
set sub_info [overtype::renderline\
-info 1\
-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]\
""\
$overflow_right\
]
set foldline [tcl::dict::get $sub_info result]
set insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
set autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
set foldline [tcl::dict::get $sub_info result]
tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
linsert outputlines $renderedrow $foldline
#review - row & col set by restore - but not if there was no save..
}
@ -745,6 +761,53 @@ tcl::namespace::eval overtype {
set col $post_render_col
#overflow + unapplied?
}
clear_and_move {
#e.g 2J
if {$post_render_row > [llength $outputlines]} {
set row [llength $outputlines]
} else {
set row $post_render_row
}
set col $post_render_col
set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant
set clearedlines [list]
foreach ln $outputlines {
lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m
if 0 {
set lineparts [punk::ansi::ta::split_codes $ln]
set numcells 0
foreach {pt _code} $lineparts {
if {$pt ne ""} {
foreach grapheme [punk::char::grapheme_split $pt] {
switch -- $grapheme {
" " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? -
a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y -
z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
incr numcells 1
}
default {
if {$grapheme eq "\u0000"} {
incr numcells 1
} else {
incr numcells [grapheme_width_cached $grapheme]
}
}
}
}
}
}
#replays/resets each line
lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m
}
}
set outputlines $clearedlines
#todo - determine background/default to be in effect - DECECM ?
puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]"
#lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0]
}
lf_start {
#raw newlines
# ----------------------
@ -780,27 +843,48 @@ tcl::namespace::eval overtype {
append rendered $overflow_right
set overflow_right ""
} else {
#review - we should really make renderline do the work...?
set overflow_width [punk::ansi::printing_length $overflow_right]
if {$visualwidth + $overflow_width <= $renderwidth} {
append rendered $overflow_right
set overflow_right ""
} else {
if {$visualwidth < $renderwidth} {
set graphemes [punk::char::grapheme_split $overflow_width]
set add ""
set addlen $visualwidth
set remaining_overflow $graphemes
foreach g $graphemes {
set w [overtype::grapheme_width_cached]
if {$addlen + $w <= $renderwidth} {
append add $g
incr addlen $w
lpop remaining_overflow
} else {
break
}
if {[tcl::dict::get $vtstate autowrap_mode]} {
set outputlines [linsert $outputlines $renderedrow $overflow_right]
set overflow_right ""
set row [expr {$renderedrow + 2}]
} else {
set overflow_right "" ;#abandon
}
if {0 && $visualwidth < $renderwidth} {
puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth"
error "incomplete - abandon?"
set overflowparts [punk::ansi::ta::split_codes $overflow_right]
set remaining_overflow $overflowparts
set filled 0
foreach {pt code} $overflowparts {
lpop remaining_overflow 0
if {$pt ne ""} {
set graphemes [punk::char::grapheme_split $pt]
set add ""
set addlen $visualwidth
foreach g $graphemes {
set w [overtype::grapheme_width_cached $g]
if {$addlen + $w <= $renderwidth} {
append add $g
incr addlen $w
} else {
set filled 1
break
}
}
append rendered $add
}
if {!$filled} {
lpop remaining_overflow 0 ;#pop code
}
}
append rendered $add
set overflow_right [join $remaining_overflow ""]
}
}
@ -829,14 +913,16 @@ tcl::namespace::eval overtype {
#we may also have other control sequences that came after col 80 e.g cursor save
if 0 {
set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]]
set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs]
set rhs ""
set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]]
set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs]
set rhs ""
#assertion - there should be no overflow..
puts $lhs
#assertion - there should be no overflow..
puts $lhs
}
if {![tcl::dict::get $vtstate insert_mode]} {
assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode
}
assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right
set row $post_render_row
#set row $renderedrow
@ -981,7 +1067,7 @@ tcl::namespace::eval overtype {
#normal single-width grapheme overflow
#puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]"
set row $post_render_row ;#renderline will not advance row when reporting overflow char
if {$autowrap_mode} {
if {[tcl::dict::get $vtstate autowrap_mode]} {
incr row
set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ??
} else {
@ -1014,7 +1100,7 @@ tcl::namespace::eval overtype {
#2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts
#todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc
if {$autowrap_mode} {
if {[tcl::dict::get $vtstate autowrap_mode]} {
if {$renderwidth < 2} {
#edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character
set idx 0
@ -1055,6 +1141,14 @@ tcl::namespace::eval overtype {
set row $post_render_row
set col $post_render_col
}
set_window_title {
set newtitle [lindex $instruction 1]
puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'"
#
}
reset_colour_palette {
puts stderr "overtype::renderspace instruction '$instruction' unimplemented"
}
default {
puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'"
}
@ -1062,7 +1156,7 @@ tcl::namespace::eval overtype {
}
if {!$opt_expand_right && !$autowrap_mode} {
if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} {
#not allowed to overflow column or wrap therefore we get overflow data to truncate
if {[tcl::dict::get $opts -ellipsis]} {
set show_ellipsis 1
@ -1160,11 +1254,22 @@ tcl::namespace::eval overtype {
}
set result [join $outputlines \n]
if {$info_mode} {
if {!$opt_info} {
return $result
} else {
#emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window?
#append result \n$instruction_stats\n
set inforesult [dict create\
result $result\
last_instruction $instruction\
instruction_stats $instruction_stats\
]
if {$opt_info == 2} {
return [pdict -channel none inforesult]
} else {
return $inforesult
}
}
return $result
}
#todo - left-right ellipsis ?
@ -2368,14 +2473,22 @@ tcl::namespace::eval overtype {
} else {
#linefeed occurred in middle or at end of text
#puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx"
incr cursor_row
if {$idx == -1 || $overflow_idx > $idx} {
#don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
if {$insert_mode == 0} {
incr cursor_row
if {$idx == -1 || $overflow_idx > $idx} {
#don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
}
set instruction lf_mid
priv::render_unapplied $overlay_grapheme_control_list $gci
break
} else {
incr cursor_row
#don't adjust the overflow_idx
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction lf_mid
break ;# could have overdata following the \n - don't keep processing
}
set instruction lf_mid
priv::render_unapplied $overlay_grapheme_control_list $gci
break
}
}
@ -3077,8 +3190,11 @@ tcl::namespace::eval overtype {
set idx [expr {$cursor_column -1}]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
if {[llength $outcols]} {
priv::render_erasechar 0 [llength $outcols]
}
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction move
set instruction clear_and_move
break
}
3 {
@ -3749,6 +3865,72 @@ tcl::namespace::eval overtype {
}
7OSC - 8OSC {
# OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit
if {[tcl::string::index $codenorm end] eq "\007"} {
set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007
} else {
set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\
}
set first_colon [tcl::string::first {;} $code_content]
if {$first_colon == -1} {
#there probably should always be a colon - but we'll try to make sense of it without
set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007
} else {
set osc_code [tcl::string::range $code_content 0 $first_colon-1]
}
switch -exact -- $osc_code {
2 {
set newtitle [tcl::string::range $code_content 2 end]
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction [list set_window_title $newtitle]
break
}
4 {
#OSC 4 - set colour palette
#can take multiple params
#e.g \x1b\]4\;1\;red\;2\;green\x1b\\
set params [tcl::string::range $code_content 1 end]
puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 {
#OSC 10 through 17 - so called 'dynamic colours'
#can take multiple params - each successive parameter changes the next colour in the list
#- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more
#10 change text foreground colour
#11 change text background colour
#12 change text cursor colour
#13 change mouse foreground colour
#14 change mouse background colour
#15 change tektronix foreground colour
#16 change tektronix background colour
#17 change highlight colour
set params [tcl::string::range $code_content 2 end]
puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
18 {
#why is this not considered one of the dynamic colours above?
#https://www.xfree86.org/current/ctlseqs.html
#tektronix cursor color
puts stderr "overtype::renderline OSC 18 - set tektronix cursor color 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
puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction [list reset_colour_palette]
break
}
default {
puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
}
default {
@ -3791,6 +3973,23 @@ tcl::namespace::eval overtype {
#how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW
set in_overflow 1
}
set trailing_nulls 0
foreach ch [lreverse $outcols] {
if {$ch eq "\u0000"} {
incr trailing_nulls
} else {
break
}
}
if {$trailing_nulls} {
set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}]
} else {
set first_tail_null_posn -1
}
#puts stderr "first_tail_null_posn: $first_tail_null_posn"
#puts stderr "colview: [ansistring VIEW $outcols]"
foreach ch $outcols {
#puts "---- [ansistring VIEW $ch]"
@ -3865,8 +4064,17 @@ tcl::namespace::eval overtype {
}
append outstring $gxleader
append outstring $sgrleader
if {$idx+1 < $cursor_column} {
append outstring [tcl::string::map {\u0000 " "} $ch]
if {$ch eq "\u0000"} {
if {$cp437_glyphs} {
#map all nulls including at tail to space
append outstring " "
} else {
if {$trailing_nulls && $i < $first_tail_null_posn} {
append outstring " " ;#map inner nulls to space
} else {
append outstring \u0000
}
}
} else {
append outstring $ch
}
@ -3874,12 +4082,20 @@ tcl::namespace::eval overtype {
incr i
}
#flower.ans good test for null handling - reverse line building
if {![ansistring length $overflow_right]} {
set outstring [tcl::string::trimright $outstring "\u0000"]
}
set outstring [tcl::string::map {\u0000 " "} $outstring]
set overflow_right [tcl::string::trimright $overflow_right "\u0000"]
set overflow_right [tcl::string::map {\u0000 " "} $overflow_right]
#review - presence of overflow_right doesn't indicate line's trailing nulls should remain.
#The cells could have been erased?
#if {!$cp437_glyphs} {
# #if {![ansistring length $overflow_right]} {
# # set outstring [tcl::string::trimright $outstring "\u0000"]
# #}
# set outstring [tcl::string::trimright $outstring "\u0000"]
# set outstring [tcl::string::map {\u0000 " "} $outstring]
#}
#REVIEW
#set overflow_right [tcl::string::trimright $overflow_right "\u0000"]
#set overflow_right [tcl::string::map {\u0000 " "} $overflow_right]
set replay_codes ""
if {[llength $understacks] > 0} {
@ -4207,8 +4423,9 @@ tcl::namespace::eval overtype::priv {
upvar outcols o
upvar understacks ustacks
upvar understacks_gx gxstacks
upvar replay_codes_overlay replay
#ECH clears character attributes from erased character positions
#ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater.
#ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater.
if {![tcl::string::is integer -strict $count] || $count < 1} {
error "render_erasechar count must be integer >= 1"
}
@ -4223,8 +4440,9 @@ tcl::namespace::eval overtype::priv {
}
set num [expr {$end - $start + 1}]
set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space?
set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list]]]
set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]]
#DECECM ???
set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]]
set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review
return
}
proc render_setchar {i c } {

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

@ -413,6 +413,7 @@ tcl::namespace::eval punk::ansi {
tcl::namespace::export\
{a?} {a+} a \
ansistring\
ansiwrap\
convert*\
clear*\
cursor_*\
@ -722,77 +723,11 @@ tcl::namespace::eval punk::ansi {
#candidate for zig/c implementation?
proc stripansi2 {text} {
set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters
join [::punk::ansi::ta::split_at_codes $text] ""
}
proc stripansi1 {text} {
#todo - character set selection - SS2 SS3 - how are they terminated? REVIEW
variable escape_terminals ;#dict
variable ::punk::ansi::ta::standalone_code_map ;#map to empty string
set text [convert_g0 $text]
set text [tcl::string::map $standalone_code_map $text]
#e.g standalone 2 byte and 3 byte VT100(?) sequences - some of these work in wezterm
#\x1b#3 double-height letters top half
#\x1b#4 double-height letters bottom half
#\x1b#5 single-width line
#\x1b#6 double-width line
#\x1b#8 dec test fill screen
#we process char by char - line-endings whether \r\n or \n should be processed as per any other character.
#Theoretically line endings can occur within an ST payload (review e.g title?)
#ecma standard says: The character string following may consist of any bit combination, except those representing SOS or STRING TERMINATOR (ST)
set inputlist [split $text ""]
set outputlist [list]
set in_escapesequence 0
#assumption - text already 'rendered' - ie no cursor movement controls . (what about backspace and lone carriage returns - they are horizontal cursor movements)
set i 0
foreach u $inputlist {
set v [lindex $inputlist $i+1]
set uv ${u}${v}
if {$in_escapesequence eq "2b"} {
#2nd byte - done.
set in_escapesequence 0
} elseif {$in_escapesequence != 0} {
set endseq [tcl::dict::get $escape_terminals $in_escapesequence]
if {$u in $endseq} {
set in_escapesequence 0
} elseif {$uv in $endseq} {
set in_escapesequence 2b ;#flag next byte as last in sequence
}
} else {
#handle both 7-bit and 8-bit CSI and OSC
if {[regexp {^(?:\033\[|\u009b)} $uv]} {
set in_escapesequence CSI
} elseif {[regexp {^(?:\033\]|\u009d)} $uv]} {
set in_escapesequence OSC
} elseif {[regexp {^(?:\033P|\u0090)} $uv]} {
set in_escapesequence DCS
} elseif {[regexp {^(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)} $uv]} {
#SOS,PM,APC - all terminated with ST
set in_escapesequence MISC
} else {
lappend outputlist $u
}
}
incr i
}
return [join $outputlist ""]
}
#review - what happens when no terminator?
#todo - map other character sets to unicode equivs? There seems to be little support for other than the DEC special graphics set.. ISO2022 character switching not widely supported - may be best considered deprecated(?)
# convert esc(0 -> esc(B graphics sequences to single char unicode equivalents e.g box drawing set
@ -2029,7 +1964,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#[para]Return an ansi string representing a table of codes and a panel showing the colours
variable SGR_setting_map
variable SGR_colour_map
set fcposn [lsearch $args "forcecol*"]
set fcposn [lsearch $args "force*"]
set fc ""
set opt_forcecolour 0
if {$fcposn >= 0} {
@ -2409,7 +2344,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything.
set forcecolour 0
set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour
set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour
if {$fcpos >= 0} {
set forcecolour 1
set args [lremove $args $fcpos]
@ -2767,7 +2702,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything.
set forcecolour 0
set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour
set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour
if {$fcpos >=0} {
set forcecolour 1
set args [lremove $args $fcpos]
@ -3199,6 +3134,16 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
return $out
}
proc move_emitblock {row col textblock} {
#*** !doctools
#[call [fun move_emitblock] [arg row] [arg col] [arg textblock]]
set commands ""
foreach ln [split $textblock \n] {
append commands [punk::ansi::move_emit $row $col $ln]
incr row
}
return $commands
}
proc move_forward {{n 1}} {
#*** !doctools
#[call [fun move_forward] [arg n]]
@ -3315,18 +3260,90 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
#Alt screen buffer
#Alt screen buffer - smcup/rmcup ti/te
#Note \x1b\[?47h doesn't work at all in some terminals (e.g alacritty,cmd on windows and reportedly kitty)
#It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals.
#see: https://xn--rpa.cc/irl/term.html
#1049 (introduced by xterm in 1998?) considered the more modern version?
#1047,1048,1049 xterm private modes are 'composite' control sequences as replacement for original 47 sequence
#1049 - includes save cursor,switch to alt screen, clear screen
#e.g ? (below example not known to be exactly what 1049 does - but it's something similar)
#SMCUP
# \x1b7 (save cursor)
# \x1b\[?47h (switch)
# \x1b\[2J (clear screen)
#RMCUP
# \x1b\[?47l (switch back)
# \x1b8 (restore cursor)
#1047 - clear screen on the way out (ony if actually on alt screen)
proc enable_alt_screen {} {
#tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen?
#\x1b\[?1049h ;#xterm
return \x1b\[?47h
return \x1b\[?1049h
}
proc disable_alt_screen {} {
#tput rmcup outputs \x1b\[?1049l\x1b\[23\;0\;0t]
#\x1b\[?1049l
return \x1b\[?1049l
}
#47 - less widely supported(?) doesn't restore cursor or clear alt screen
proc enable_alt_screen2 {} {
return \x1b\[?47h
}
proc disable_alt_screen2 {} {
return \x1b\[?47l
}
proc term_colour_fg {colour} {
return "\x1b\]10\;$colour\x1b\\"
}
proc term_color_fg {colour} {
return "\x1b\]10\;$colour\x1b\\"
}
proc term_colour_bg {colour} {
return "\x1b\]11\;$colour\x1b\\"
}
proc term_color_bg {colour} {
return "\x1b\]11\;$colour\x1b\\"
}
proc term_colour_cursor {colour} {
return "\x1b\]12\;$colour\x1b\\"
}
proc term_color_cursor {colour} {
return "\x1b\]12\;$colour\x1b\\"
}
proc term_colour_pointer_fg {colour} {
return "\x1b\]13\;$colour\x1b\\"
}
proc term_color_pointer_fg {colour} {
return "\x1b\]13\;$colour\x1b\\"
}
proc term_colour_pointer_bg {colour} {
return "\x1b\]14\;$colour\x1b\\"
}
proc term_color_pointer_bg {colour} {
return "\x1b\]14\;$colour\x1b\\"
}
#15,16 tektronix fg, tektronix bg ???
proc term_colour_highlight_bg {colour} {
return "\x1b\]17\;$colour\x1b\\"
}
proc term_color_highlight_bg {colour} {
return "\x1b\]17\;$colour\x1b\\"
}
#18 tektronix cursor colour ???
proc term_colour_highlight_fg {colour} {
return "\x1b\]19\;$colour\x1b\\"
}
proc term_color_highlight_fg {colour} {
return "\x1b\]19\;$colour\x1b\\"
}
#22 pointer shape - there are other methods too - not known to work on windows terminal based VTs - review
proc term_colour_reset {} {
return "\x1b\]104\;\x1b\\"
}
proc term_color_reset {} {
return "\x1b\]104\;\x1b\\"
}
# -- --- ---
proc erase_line {} {
@ -4398,6 +4415,10 @@ tcl::namespace::eval punk::ansi::ta {
variable re_ansi_detect_open
expr {[regexp $re_ansi_detect_open $text]}
}
proc detect_st_open {text} {
variable re_ST_open
expr {[regexp $re_ST_open $text]}
}
#not in perl ta
proc detect_csi {text} {
@ -4672,7 +4693,8 @@ tcl::namespace::eval punk::ansi::class {
}
oo::class create base_renderer {
variable o_width
variable o_wrap o_overflow o_appendlines o_looplimit
variable o_autowrap_mode
variable o_overflow o_appendlines o_looplimit
variable o_cursor_column o_cursor_row
#variable o_render_index ;#index of input (from_ansistring) grapheme/ansi-code that *has* been rendered
@ -4690,25 +4712,33 @@ tcl::namespace::eval punk::ansi::class {
}
tcl::namespace::path $nspath
#-- --
if {[llength $args] < 2} {
error {usage: ?-width <int>? ?-wrap [1|0]? ?-overflow [1|0]? from_ansistring to_ansistring}
if {[llength $args] < 1} {
error {usage: ?-width <int>? ?-height <height>? ?-autowrap_mode [1|0]? ?-overflow [1|0]? from_ansistring}
}
lassign [lrange $args end-1 end] from_ansistring to_ansistring
#lassign [lrange $args end-1 end] from_ansistring to_ansistring
set from_ansistring [lindex $args end]
set opts [tcl::dict::create\
-width \uFFEF\
-wrap 1\
-overflow 0\
-appendlines 1\
-looplimit 15000\
-experimental {}\
-cursor_column 1\
-cursor_row 1\
-width \uFFEF\
-height \uFFEF\
-overflow 0\
-appendlines 1\
-looplimit 15000\
-experimental {}\
-cursor_column 1\
-cursor_row 1\
-insert_mode 0\
-autowrap_mode 1\
-initial_ansistring ""\
]
puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring"
set argsflags [lrange $args 0 end-2]
foreach {k v} $argsflags {
switch -- $k {
-width - -wrap - -overflow - -appendlines - -looplimit - -experimental {
-width - -height -
-overflow - -appendlines - -looplimit - -experimental -
-autowrap_mode -
-insert_mode -
-initial_ansistring {
tcl::dict::set opts $k $v
}
default {
@ -4717,8 +4747,19 @@ tcl::namespace::eval punk::ansi::class {
}
}
}
set initial_ansistring [tcl::dict::get $opts -initial_ansistring]
if {$initial_ansistring eq ""} {
set to_ansistring [punk::ansi::class::class_ansistring new ""]
} else {
#todo - verify obj vs raw string
set to_ansistring $initial_ansistring
}
puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring"
set o_width [tcl::dict::get $opts -width]
set o_wrap [tcl::dict::get $opts -wrap]
set o_height [tcl::dict::get $opts -height]
set o_autowrap_mode [tcl::dict::get $opts -autowrap_mode]
set o_insert_mode [tcl::dict::get $opts -insert_mode]
set o_overflow [tcl::dict::get $opts -overflow]
set o_appendlines [tcl::dict::get $opts -appendlines]
set o_looplimit [tcl::dict::get $opts -looplimit]
@ -4736,6 +4777,9 @@ tcl::namespace::eval punk::ansi::class {
method eval_in {script} {
eval $script
}
method renderbuf {} {
return $o_to_ansistring
}
method cursor_column {{col ""}} {
if {$col eq ""} {
return $o_cursor_column
@ -4755,6 +4799,12 @@ tcl::namespace::eval punk::ansi::class {
set o_cursor_row $row
}
#set/query cursor state
method cursor_state {args} {
lassign $args r c
return [dict create row [my cursor_row $r] column [my cursor_column $c]]
}
#consider scroll area
#we need to render to something with a concept of viewport, offscreen above,below,left,right?
method rendernext {} {
@ -4834,7 +4884,8 @@ tcl::namespace::eval punk::ansi::class {
#set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext]
}
}
#renderspace equivalent? channel based?
#todo
$o_to_ansistring append $newtext
return [tcl::dict::create type $type_rendered rendercount $rendercount start_count_unrendered $start_elements_unrendered end_count_unrendered $end_elements_unrendered]
@ -4960,11 +5011,10 @@ tcl::namespace::eval punk::ansi::class {
if {$o_renderer ne ""} {
append result \n " renderer obj: $o_renderer"
append result \n " renderer class: [info object class $o_renderer]"
}
if {$o_renderout ne ""} {
append result \n " render target ansistring: $o_renderout"
append result \n " render target has ansi : [$o_renderout has_ansi]"
append result \n " render target count : [$o_renderout count]"
set renderstring [$o_renderer renderbuf]
append result \n " render target ansistring: $renderstring"
append result \n " render target has ansi : [$renderstring has_ansi]"
append result \n " render target count : [$renderstring count]"
}
if {$verbose} {
append result \n "ansisplits listing"
@ -5052,7 +5102,8 @@ tcl::namespace::eval punk::ansi::class {
}
method strippedlength {} {
if {![llength $o_ansisplits]} {my MakeSplit}
#review
return [string length [join $o_ptlist ""]]
}
#returns the ansiless string - doesn't affect the stored state other than initialising it's internal state if it wasn't already
method stripped {} {
@ -5119,10 +5170,9 @@ tcl::namespace::eval punk::ansi::class {
if {$rtype ni $rtypes} {
error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)"
}
if {$o_renderout eq ""} {
#tell ansistring that it's a renderbuf for another ansistring? point it to the renderer or the parent ansistring?
set o_renderout [punk::ansi::class::class_ansistring new ""]
}
#if {$o_renderout eq ""} {
# set o_renderout [punk::ansi::class::class_ansistring new ""]
#}
if {$o_renderer ne ""} {
set oinfo [info object class $o_renderer]
set tail [tcl::namespace::tail $oinfo]
@ -5130,13 +5180,15 @@ tcl::namespace::eval punk::ansi::class {
if {$rtype ne $currenttype} {
puts "switch rendertype from $currenttype to $rtype - destroying renderer and creating a new one"
$o_renderer destroy ;#what happens to data in target ansistring obj? when does it make sense to keep output and keep rendering vs clearing?
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
#set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]]
} else {
return $currenttype
}
} else {
puts "creating first renderer"
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
#set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]]
}
}
#--- progressive rendering buffer - another ansistring object
@ -5149,10 +5201,13 @@ tcl::namespace::eval punk::ansi::class {
return $o_renderwidth
}
#re-render if needed?
puts stderr "renderwidth todo? re-render?"
set o_renderwidth $rw
}
method renderer {} {
return $o_renderer
}
method render_state {} {
#? report state of render.. we will primarily be using plaintext/ansisequence as the chunk/operation boundary
#but - as we can append char sequences directly to the tail split - it's not enough to track which split element we have rendered - but we also need how many graphemes or code sequences we are into the last split.
@ -5160,10 +5215,36 @@ tcl::namespace::eval punk::ansi::class {
}
method renderbuf {} {
#get the underlying renderobj - if any
return $o_renderout ;#also class_ansistring
#return $o_renderout ;#also class_ansistring
return [$o_renderer renderbuf]
}
method render {} {
method render {{maxgraphemes ""}} {
#full render - return buffer ansistring
set do_render 1
set grapheme_count 0
set other_count 0
if {$maxgraphemes eq ""} {
while {$do_render} {
set rendition [my rendernext]
set do_render [dict get $rendition rendercount]
if {[dict get $rendition type] eq "g"} {
incr grapheme_count $do_render
} else {
incr other_count $do_render
}
}
} else {
while {$do_render && $grapheme_count <= $maxgraphemes} {
set rendition [my rendernext]
set do_render [dict get $rendition rendercount]
if {[dict get $rendition type] eq "g"} {
incr grapheme_count $do_render
} else {
incr other_count $do_render
}
}
}
return [dict create graphemes $grapheme_count other $other_count]
}
method rendernext {} {
#render next available pt/code chunk only - not to end of available input
@ -5198,6 +5279,13 @@ tcl::namespace::eval punk::ansi::class {
#i.e a 'rendered' ANSI string should contain just ANSI SGR character attributes and linefeeds for rows
#Knowing which is which can be helpful as far as use of any methods which use the concepts of terminal row/column
#like Tcl's append class_ansistring append returns the result directly - which for ANSI - can be inconvenient in the terminal
#class_ansistring append_string is a convenience wrapper to avoid returning the raw result
method append_string {args} {
my append {*}$args
return
}
#analagous to Tcl string append
#MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient
method append {args} {
@ -5369,7 +5457,7 @@ tcl::namespace::eval punk::ansi::class {
}
#method append_and_render - append and render up to end of appended data at same time
#method append_and_render? - append and render up to end of appended data at same time
method view {args} {
if {$o_string eq ""} {

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

@ -864,6 +864,7 @@ namespace eval punk::console {
#Turning ansi off only stops new ansi being generated - but what about codes stored in configurations of existing elements such as tables/frames?
#It will stop underlines/bold/reverse as well as SGR colours
#what about ansi movement codes etc?
#we already have colour on|off which disables SGR codes in a+ etc as well as stderr/stdout channel transforms
proc ansi {{onoff {}}} {
variable ansi_wanted
if {[string length $onoff]} {
@ -891,6 +892,7 @@ namespace eval punk::console {
}
}
catch {punk::repl::reset_prompt}
puts stderr "::punk::console::ansi - use 'colour' command to turn SGR codes on/off"
return [expr {$ansi_wanted}]
}
@ -1295,10 +1297,10 @@ namespace eval punk::console {
if {![catch {twapi::set_console_title $windowtitle} result]} {
return $windowtitle
} else {
error "punk::console::titleset failed to set title - try punk::console::ansi::titleset"
error "punk::console::local::titleset failed to set title - try punk::console::ansi::titleset"
}
} else {
error "punk::console::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset"
error "punk::console::local::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset"
}
}
proc titleget {} {
@ -1306,12 +1308,12 @@ namespace eval punk::console {
if {![catch {twapi::get_console_title} result]} {
return $result
} else {
error "punk::console::titleset failed to set title - ensure twapi is available"
error "punk::console::local::titleset failed to set title - ensure twapi is available"
}
} else {
#titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title
# won't work on all platforms/terminals - but may be worth implementing
error "punk::console::titleget has no local mechanism to get the window title on this platform."
# won't work on all platforms/terminals - but may be worth implementing (for overtype::renderspace / frames etc)
error "punk::console::local::titleget has no local mechanism to get the window title on this platform."
}
}
}
@ -1327,7 +1329,7 @@ namespace eval punk::console {
if { $ansi_wanted <= 0} {
punk::console::local::titleset $windowtitle
} else {
tailcall ansi::titleset $windowtitle
ansi::titleset $windowtitle
}
}
#no known pure-ansi solution
@ -1486,8 +1488,6 @@ namespace eval punk::console {
namespace import ansi::insert_lines
namespace import ansi::delete_lines
interp alias {} smcup {} ::punk::console::enable_alt_screen
interp alias {} rmcup {} ::punk::console::disable_alt_screen
#experimental
proc rhs_prompt {col text} {
@ -1881,12 +1881,6 @@ namespace eval punk::console {
interp alias {} colour {} punk::console::colour
interp alias {} ansi {} punk::console::ansi
interp alias {} color {} punk::console::colour
interp alias {} a+ {} punk::console::code_a+
interp alias {} a {} punk::console::code_a
interp alias {} a? {} punk::console::code_a?

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

@ -1561,7 +1561,8 @@ tcl::namespace::eval punk::ns {
#set name [string trim $name :]
#set origin [namespace origin ${upns}::$name]
set origin [nseval $targetns [list ::namespace origin $name]]
set origin [nseval $targetns [list ::namespace origin $name]]
set resolved [nseval $targetns [list ::namespace which $name]]
#An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases!
if {$origin ni [info procs $origin]} {
@ -1613,7 +1614,8 @@ tcl::namespace::eval punk::ns {
}
lappend argl $a
}
list proc [nsjoin ${targetns} $name] $argl $body
#list proc [nsjoin ${targetns} $name] $argl $body
list proc $resolved $argl $body
}

BIN
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm

Binary file not shown.

37
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm

@ -4041,6 +4041,9 @@ tcl::namespace::eval textblock {
(default 0 if no existing -table supplied)"
-table -default "" -type string -help "existing table object to use"
-headers -default "" -help "list of header values. Must match number of columns"
-show_header -default "" -help "Whether to show a header row.
Leave as empty string for unspecified/automatic,
in which case it will display only if -headers list was supplied."
-action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied
if append is chosen the new values will always start at the first column"
-columns -default "" -type integer -help "Number of table columns
@ -4101,11 +4104,34 @@ tcl::namespace::eval textblock {
}
} else {
set is_new_table 1
set headers {}
if {[tcl::dict::get $opts -headers] ne ""} {
set headers [dict get $opts -headers]
if {[tcl::dict::get $opts -show_header] eq ""} {
set show_header 1
} else {
set show_header [tcl::dict::get $opts -show_header]
}
} else {
if {[tcl::dict::get $opts -show_header] eq ""} {
set show_header 0
} else {
set show_header [tcl::dict::get $opts -show_header]
}
}
if {[tcl::string::is integer -strict $opt_columns]} {
set cols $opt_columns
if {[llength $headers] && $cols != [llength $headers]} {
error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $headers])"
}
} else {
#review
set cols 2 ;#seems a reasonable default
if {[llength $headers]} {
set cols [llength $headers]
} else {
set cols 2 ;#seems a reasonable default
}
}
#defaults for new table only
if {[tcl::dict::get $opts -frametype] eq ""} {
@ -4123,15 +4149,6 @@ tcl::namespace::eval textblock {
if {[tcl::dict::get $opts -show_hseps] eq ""} {
tcl::dict::set opts -show_hseps 0
}
set headers {}
set show_header 0
if {[tcl::dict::get $opts -headers] ne ""} {
set headers [dict get $opts -headers]
if {[llength $headers] ne $cols} {
error "list_as_table number of headers ([llength $headers]) must match number of columns ($cols)"
}
set show_header 1
}
set t [textblock::class::table new\
-show_header $show_header\

3357
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.1.tm

File diff suppressed because it is too large Load Diff

246
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.8.tm

@ -0,0 +1,246 @@
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# UUIDs are 128 bit values that attempt to be unique in time and space.
#
# Reference:
# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt
#
# uuid: scheme:
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html
#
# Usage: uuid::uuid generate
# uuid::uuid equal $idA $idB
package require Tcl 8.5 9
namespace eval uuid {
variable accel
array set accel {critcl 0}
namespace export uuid
variable uid
if {![info exists uid]} {
set uid 1
}
proc K {a b} {set a}
}
###
# Optimization
# Caches machine info after the first pass
###
proc ::uuid::generate_tcl_machinfo {} {
variable machinfo
if {[info exists machinfo]} {
return $machinfo
}
lappend machinfo [clock seconds]; # timestamp
lappend machinfo [clock clicks]; # system incrementing counter
lappend machinfo [info hostname]; # spatial unique id (poor)
lappend machinfo [pid]; # additional entropy
lappend machinfo [array get ::tcl_platform]
###
# If we have /dev/urandom just stream 128 bits from that
###
if {[file exists /dev/urandom]} {
set fin [open /dev/urandom r]
fconfigure $fin -encoding binary
binary scan [read $fin 128] H* machinfo
close $fin
} elseif {[catch {package require nettool}]} {
# More spatial information -- better than hostname.
# bug 1150714: opening a server socket may raise a warning messagebox
# with WinXP firewall, using ipconfig will return all IP addresses
# including ipv6 ones if available. ipconfig is OK on win98+
if {[string equal $::tcl_platform(platform) "windows"]} {
catch {exec ipconfig} config
lappend machinfo $config
} else {
catch {
set s [socket -server void -myaddr [info hostname] 0]
K [fconfigure $s -sockname] [close $s]
} r
lappend machinfo $r
}
if {[package provide Tk] != {}} {
lappend machinfo [winfo pointerxy .]
lappend machinfo [winfo id .]
}
} else {
###
# If the nettool package works on this platform
# use the stream of hardware ids from it
###
lappend machinfo {*}[::nettool::hwid_list]
}
return $machinfo
}
# Generates a binary UUID as per the draft spec. We generate a pseudo-random
# type uuid (type 4). See section 3.4
#
proc ::uuid::generate_tcl {} {
package require md5 2
variable uid
set tok [md5::MD5Init]
md5::MD5Update $tok [incr uid]; # package incrementing counter
foreach string [generate_tcl_machinfo] {
md5::MD5Update $tok $string
}
set r [md5::MD5Final $tok]
binary scan $r c* r
# 3.4: set uuid versioning fields
lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}]
lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}]
return [binary format c* $r]
}
if {[string equal $tcl_platform(platform) "windows"]
&& [package provide critcl] != {}} {
namespace eval uuid {
critcl::ccode {
#define WIN32_LEAN_AND_MEAN
#define STRICT
#include <windows.h>
#include <ole2.h>
typedef long (__stdcall *LPFNUUIDCREATE)(UUID *);
typedef const unsigned char cu_char;
}
critcl::cproc generate_c {Tcl_Interp* interp} ok {
HRESULT hr = S_OK;
int r = TCL_OK;
UUID uuid = {0};
HMODULE hLib;
LPFNUUIDCREATE lpfnUuidCreate = NULL;
hLib = LoadLibraryA(("rpcrt4.dll"));
if (hLib)
lpfnUuidCreate = (LPFNUUIDCREATE)
GetProcAddress(hLib, "UuidCreate");
if (lpfnUuidCreate) {
Tcl_Obj *obj;
lpfnUuidCreate(&uuid);
obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid));
Tcl_SetObjResult(interp, obj);
} else {
Tcl_SetResult(interp, "error: failed to create a guid",
TCL_STATIC);
r = TCL_ERROR;
}
return r;
}
}
}
# Convert a binary uuid into its string representation.
#
proc ::uuid::tostring {uuid} {
binary scan $uuid H* s
foreach {a b} {0 7 8 11 12 15 16 19 20 end} {
append r [string range $s $a $b] -
}
return [string tolower [string trimright $r -]]
}
# Convert a string representation of a uuid into its binary format.
#
proc ::uuid::fromstring {uuid} {
return [binary format H* [string map {- {}} $uuid]]
}
# Compare two uuids for equality.
#
proc ::uuid::equal {left right} {
set l [fromstring $left]
set r [fromstring $right]
return [string equal $l $r]
}
# Call our generate uuid implementation
proc ::uuid::generate {} {
variable accel
if {$accel(critcl)} {
return [generate_c]
} else {
return [generate_tcl]
}
}
# uuid generate -> string rep of a new uuid
# uuid equal uuid1 uuid2
#
proc uuid::uuid {cmd args} {
switch -exact -- $cmd {
generate {
if {[llength $args] != 0} {
return -code error "wrong # args:\
should be \"uuid generate\""
}
return [tostring [generate]]
}
equal {
if {[llength $args] != 2} {
return -code error "wrong \# args:\
should be \"uuid equal uuid1 uuid2\""
}
return [eval [linsert $args 0 equal]]
}
default {
return -code error "bad option \"$cmd\":\
must be generate or equal"
}
}
}
# -------------------------------------------------------------------------
# LoadAccelerator --
#
# This package can make use of a number of compiled extensions to
# accelerate the digest computation. This procedure manages the
# use of these extensions within the package. During normal usage
# this should not be called, but the test package manipulates the
# list of enabled accelerators.
#
proc ::uuid::LoadAccelerator {name} {
variable accel
set r 0
switch -exact -- $name {
critcl {
if {![catch {package require tcllibc}]} {
set r [expr {[info commands ::uuid::generate_c] != {}}]
}
}
default {
return -code error "invalid accelerator package:\
must be one of [join [array names accel] {, }]"
}
}
set accel($name) $r
}
# -------------------------------------------------------------------------
# Try and load a compiled extension to help.
namespace eval ::uuid {
variable e {}
foreach e {critcl} {
if {[LoadAccelerator $e]} break
}
unset e
}
package provide uuid 1.0.8
# -------------------------------------------------------------------------
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:

4
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config

@ -6,7 +6,6 @@
set bootsupport_modules [list\
src/vendormodules cksum\
src/vendormodules modpod\
src/vendormodules natsort\
src/vendormodules overtype\
src/vendormodules oolib\
src/vendormodules http\
@ -22,6 +21,8 @@ set bootsupport_modules [list\
src/vendormodules uuid\
src/vendormodules md5\
src/vendormodules sha1\
src/vendormodules tomlish\
src/vendormodules test::tomlish\
modules punkcheck\
modules natsort\
modules punk::ansi\
@ -60,6 +61,7 @@ set bootsupport_modules [list\
modules punk::zip\
modules punk::winpath\
modules textblock\
modules natsort\
modules oolib\
]

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

@ -233,7 +233,6 @@ tcl::namespace::eval overtype {
-width \uFFEF\
-height \uFFEF\
-startcolumn 1\
-wrap 0\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
@ -243,11 +242,13 @@ tcl::namespace::eval overtype {
-exposed1 \uFFFD\
-exposed2 \uFFFD\
-experimental 0\
-cp437 1\
-cp437 0\
-looplimit \uFFEF\
-crm_mode 0\
-reverse_mode 0\
-insert_mode 0\
-wrap 0\
-info 0\
-console {stdin stdout stderr}\
]
#expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally..
@ -263,14 +264,19 @@ tcl::namespace::eval overtype {
#-ellipsis args not used if -wrap is true
foreach {k v} $argsflags {
switch -- $k {
-looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace
-looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace
- -transparent - -exposed1 - -exposed2 - -experimental
- -expand_right - -appendlines
- -reverse_mode - -crm_mode - -insert_mode
- -cp437
- -console {
- -info - -console {
tcl::dict::set opts $k $v
}
-wrap - -autowrap_mode {
#temp alias -autowrap_mode for consistency with renderline
#todo -
tcl::dict::set opts -wrap $v
}
default {
error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]"
}
@ -280,10 +286,6 @@ tcl::namespace::eval overtype {
# -- --- --- --- --- ---
#review - expand_left for RTL text?
set opt_expand_right [tcl::dict::get $opts -expand_right]
#####
# review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?.
set opt_wrap [tcl::dict::get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo)
#####
#for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line.
set opt_width [tcl::dict::get $opts -width]
set opt_height [tcl::dict::get $opts -height]
@ -298,50 +300,34 @@ tcl::namespace::eval overtype {
set opt_crm_mode [tcl::dict::get $opts -crm_mode]
set opt_reverse_mode [tcl::dict::get $opts -reverse_mode]
set opt_insert_mode [tcl::dict::get $opts -insert_mode]
#####
# review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?.
set opt_autowrap_mode [tcl::dict::get $opts -wrap]
#??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo)
#####
# -- --- --- --- --- ---
set opt_cp437 [tcl::dict::get $opts -cp437]
set opt_info [tcl::dict::get $opts -info]
#initial state for renderspace 'terminal' reset
set initial_state [dict create\
-width $opt_width\
-height $opt_height\
-crm_mode $opt_crm_mode\
-reverse_mode $opt_reverse_mode\
-insert_mode $opt_insert_mode\
-cp437 $opt_cp437\
]
# ----------------------------
# -experimental dev flag to set flags etc
# ----------------------------
set data_mode 0
set info_mode 0
set edit_mode 0
set opt_experimental [tcl::dict::get $opts -experimental]
foreach o $opt_experimental {
switch -- $o {
old_mode {
set info_mode 1
}
data_mode {
set data_mode 1
}
info_mode {
set info_mode 1
}
edit_mode {
set edit_mode 1
}
}
}
# ----------------------------
#modes
set insert_mode $opt_insert_mode ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l
set autowrap_mode $opt_wrap
set reverse_mode $opt_reverse_mode
set crm_mode $opt_crm_mode
set underblock [tcl::string::map {\r\n \n} $underblock]
@ -367,6 +353,20 @@ tcl::namespace::eval overtype {
set renderwidth $opt_width
set renderheight $opt_height
}
#initial state for renderspace 'terminal' reset
set initial_state [dict create\
renderwidth $renderwidth\
renderheight $renderheight\
crm_mode $opt_crm_mode\
reverse_mode $opt_reverse_mode\
insert_mode $opt_insert_mode\
autowrap_mode $opt_autowrap_mode\
cp437 $opt_cp437\
]
#modes
#e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l
#opt_startcolumn ?? - DECSLRM ?
set vtstate $initial_state
# -- --- --- ---
#REVIEW - do we need ansi resets in the underblock?
@ -494,50 +494,55 @@ tcl::namespace::eval overtype {
}
#review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary -
#but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l
set renderargs [list -experimental $opt_experimental\
-cp437 $opt_cp437\
-info 1\
-crm_mode $crm_mode\
-insert_mode $insert_mode\
-autowrap_mode $autowrap_mode\
-reverse_mode $reverse_mode\
-cursor_restore_attributes $cursor_saved_attributes\
-transparent $opt_transparent\
-width $renderwidth\
-exposed1 $opt_exposed1\
-exposed2 $opt_exposed2\
-expand_right $opt_expand_right\
-cursor_column $col\
-cursor_row $row\
set renderargs [list -experimental $opt_experimental\
-cp437 $opt_cp437\
-info 1\
-crm_mode [tcl::dict::get $vtstate crm_mode]\
-insert_mode [tcl::dict::get $vtstate insert_mode]\
-autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\
-reverse_mode [tcl::dict::get $vtstate reverse_mode]\
-cursor_restore_attributes $cursor_saved_attributes\
-transparent $opt_transparent\
-width [tcl::dict::get $vtstate renderwidth]\
-exposed1 $opt_exposed1\
-exposed2 $opt_exposed2\
-expand_right $opt_expand_right\
-cursor_column $col\
-cursor_row $row\
$undertext\
$overtext\
]
set LASTCALL $renderargs
set rinfo [renderline {*}$renderargs]
set instruction [tcl::dict::get $rinfo instruction]
set insert_mode [tcl::dict::get $rinfo insert_mode]
set autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;#
set reverse_mode [tcl::dict::get $rinfo reverse_mode]
set instruction [tcl::dict::get $rinfo instruction]
tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode]
tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode]
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;#
tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode]
#how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack?
# - review - the answer is probably that we don't need to - it is set/reset only during application of overtext
set crm_mode [tcl::dict::get $rinfo crm_mode]
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set overflow_right_column [tcl::dict::get $rinfo overflow_right_column]
set unapplied [tcl::dict::get $rinfo unapplied]
set unapplied_list [tcl::dict::get $rinfo unapplied_list]
set post_render_col [tcl::dict::get $rinfo cursor_column]
set post_render_row [tcl::dict::get $rinfo cursor_row]
set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position]
set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes]
set visualwidth [tcl::dict::get $rinfo visualwidth]
set insert_lines_above [tcl::dict::get $rinfo insert_lines_above]
set insert_lines_below [tcl::dict::get $rinfo insert_lines_below]
tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay]
#Note carefully the difference betw overflow_right and unapplied.
#overflow_right may need to be included in next run before the unapplied data
#overflow_right most commonly has data when in insert_mode
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set overflow_right_column [tcl::dict::get $rinfo overflow_right_column]
set unapplied [tcl::dict::get $rinfo unapplied]
set unapplied_list [tcl::dict::get $rinfo unapplied_list]
set post_render_col [tcl::dict::get $rinfo cursor_column]
set post_render_row [tcl::dict::get $rinfo cursor_row]
set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position]
set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes]
set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line
set insert_lines_above [tcl::dict::get $rinfo insert_lines_above]
set insert_lines_below [tcl::dict::get $rinfo insert_lines_below]
tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay]
#lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay]
set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]
if {0 && $reverse_mode} {
if {0 && [tcl::dict::get $vtstate reverse_mode]} {
#test branch - todo - prune
puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered"
#review
@ -593,19 +598,29 @@ tcl::namespace::eval overtype {
#todo - handle potential insertion mode as above for cursor restore?
#keeping separate branches for debugging - review and merge as appropriate when stable
tcl::dict::incr instruction_stats $instruction
switch -- $instruction {
set instruction_type [lindex $instruction 0] ;#some instructions have params
tcl::dict::incr instruction_stats $instruction_type
switch -- $instruction_type {
reset {
#reset the 'renderspace terminal' (not underlying terminal)
set row 1
set col 1
set vtstate [tcl::dict::merge $vtstate $initial_state]
#todo - clear screen
}
{} {
#end of supplied line input
#lf included in data
set row $post_render_row
set col $post_render_col
if {![llength $unapplied_list]} {
if {$overflow_right ne ""} {
incr row
}
} else {
puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)"
}
set col $opt_startcolumn
}
up {
@ -708,17 +723,18 @@ tcl::namespace::eval overtype {
puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]"
set sub_info [overtype::renderline -info 1\
-width $renderwidth\
-insert_mode $insert_mode\
-autowrap_mode $autowrap_mode\
set sub_info [overtype::renderline\
-info 1\
-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]\
""\
$overflow_right\
]
set foldline [tcl::dict::get $sub_info result]
set insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
set autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
set foldline [tcl::dict::get $sub_info result]
tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
linsert outputlines $renderedrow $foldline
#review - row & col set by restore - but not if there was no save..
}
@ -745,6 +761,53 @@ tcl::namespace::eval overtype {
set col $post_render_col
#overflow + unapplied?
}
clear_and_move {
#e.g 2J
if {$post_render_row > [llength $outputlines]} {
set row [llength $outputlines]
} else {
set row $post_render_row
}
set col $post_render_col
set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant
set clearedlines [list]
foreach ln $outputlines {
lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m
if 0 {
set lineparts [punk::ansi::ta::split_codes $ln]
set numcells 0
foreach {pt _code} $lineparts {
if {$pt ne ""} {
foreach grapheme [punk::char::grapheme_split $pt] {
switch -- $grapheme {
" " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? -
a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y -
z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
incr numcells 1
}
default {
if {$grapheme eq "\u0000"} {
incr numcells 1
} else {
incr numcells [grapheme_width_cached $grapheme]
}
}
}
}
}
}
#replays/resets each line
lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m
}
}
set outputlines $clearedlines
#todo - determine background/default to be in effect - DECECM ?
puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]"
#lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0]
}
lf_start {
#raw newlines
# ----------------------
@ -780,27 +843,48 @@ tcl::namespace::eval overtype {
append rendered $overflow_right
set overflow_right ""
} else {
#review - we should really make renderline do the work...?
set overflow_width [punk::ansi::printing_length $overflow_right]
if {$visualwidth + $overflow_width <= $renderwidth} {
append rendered $overflow_right
set overflow_right ""
} else {
if {$visualwidth < $renderwidth} {
set graphemes [punk::char::grapheme_split $overflow_width]
set add ""
set addlen $visualwidth
set remaining_overflow $graphemes
foreach g $graphemes {
set w [overtype::grapheme_width_cached]
if {$addlen + $w <= $renderwidth} {
append add $g
incr addlen $w
lpop remaining_overflow
} else {
break
}
if {[tcl::dict::get $vtstate autowrap_mode]} {
set outputlines [linsert $outputlines $renderedrow $overflow_right]
set overflow_right ""
set row [expr {$renderedrow + 2}]
} else {
set overflow_right "" ;#abandon
}
if {0 && $visualwidth < $renderwidth} {
puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth"
error "incomplete - abandon?"
set overflowparts [punk::ansi::ta::split_codes $overflow_right]
set remaining_overflow $overflowparts
set filled 0
foreach {pt code} $overflowparts {
lpop remaining_overflow 0
if {$pt ne ""} {
set graphemes [punk::char::grapheme_split $pt]
set add ""
set addlen $visualwidth
foreach g $graphemes {
set w [overtype::grapheme_width_cached $g]
if {$addlen + $w <= $renderwidth} {
append add $g
incr addlen $w
} else {
set filled 1
break
}
}
append rendered $add
}
if {!$filled} {
lpop remaining_overflow 0 ;#pop code
}
}
append rendered $add
set overflow_right [join $remaining_overflow ""]
}
}
@ -829,14 +913,16 @@ tcl::namespace::eval overtype {
#we may also have other control sequences that came after col 80 e.g cursor save
if 0 {
set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]]
set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs]
set rhs ""
set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]]
set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs]
set rhs ""
#assertion - there should be no overflow..
puts $lhs
#assertion - there should be no overflow..
puts $lhs
}
if {![tcl::dict::get $vtstate insert_mode]} {
assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode
}
assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right
set row $post_render_row
#set row $renderedrow
@ -981,7 +1067,7 @@ tcl::namespace::eval overtype {
#normal single-width grapheme overflow
#puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]"
set row $post_render_row ;#renderline will not advance row when reporting overflow char
if {$autowrap_mode} {
if {[tcl::dict::get $vtstate autowrap_mode]} {
incr row
set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ??
} else {
@ -1014,7 +1100,7 @@ tcl::namespace::eval overtype {
#2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts
#todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc
if {$autowrap_mode} {
if {[tcl::dict::get $vtstate autowrap_mode]} {
if {$renderwidth < 2} {
#edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character
set idx 0
@ -1055,6 +1141,14 @@ tcl::namespace::eval overtype {
set row $post_render_row
set col $post_render_col
}
set_window_title {
set newtitle [lindex $instruction 1]
puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'"
#
}
reset_colour_palette {
puts stderr "overtype::renderspace instruction '$instruction' unimplemented"
}
default {
puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'"
}
@ -1062,7 +1156,7 @@ tcl::namespace::eval overtype {
}
if {!$opt_expand_right && !$autowrap_mode} {
if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} {
#not allowed to overflow column or wrap therefore we get overflow data to truncate
if {[tcl::dict::get $opts -ellipsis]} {
set show_ellipsis 1
@ -1160,11 +1254,22 @@ tcl::namespace::eval overtype {
}
set result [join $outputlines \n]
if {$info_mode} {
if {!$opt_info} {
return $result
} else {
#emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window?
#append result \n$instruction_stats\n
set inforesult [dict create\
result $result\
last_instruction $instruction\
instruction_stats $instruction_stats\
]
if {$opt_info == 2} {
return [pdict -channel none inforesult]
} else {
return $inforesult
}
}
return $result
}
#todo - left-right ellipsis ?
@ -2368,14 +2473,22 @@ tcl::namespace::eval overtype {
} else {
#linefeed occurred in middle or at end of text
#puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx"
incr cursor_row
if {$idx == -1 || $overflow_idx > $idx} {
#don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
if {$insert_mode == 0} {
incr cursor_row
if {$idx == -1 || $overflow_idx > $idx} {
#don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
}
set instruction lf_mid
priv::render_unapplied $overlay_grapheme_control_list $gci
break
} else {
incr cursor_row
#don't adjust the overflow_idx
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction lf_mid
break ;# could have overdata following the \n - don't keep processing
}
set instruction lf_mid
priv::render_unapplied $overlay_grapheme_control_list $gci
break
}
}
@ -3077,8 +3190,11 @@ tcl::namespace::eval overtype {
set idx [expr {$cursor_column -1}]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
if {[llength $outcols]} {
priv::render_erasechar 0 [llength $outcols]
}
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction move
set instruction clear_and_move
break
}
3 {
@ -3749,6 +3865,72 @@ tcl::namespace::eval overtype {
}
7OSC - 8OSC {
# OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit
if {[tcl::string::index $codenorm end] eq "\007"} {
set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007
} else {
set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\
}
set first_colon [tcl::string::first {;} $code_content]
if {$first_colon == -1} {
#there probably should always be a colon - but we'll try to make sense of it without
set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007
} else {
set osc_code [tcl::string::range $code_content 0 $first_colon-1]
}
switch -exact -- $osc_code {
2 {
set newtitle [tcl::string::range $code_content 2 end]
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction [list set_window_title $newtitle]
break
}
4 {
#OSC 4 - set colour palette
#can take multiple params
#e.g \x1b\]4\;1\;red\;2\;green\x1b\\
set params [tcl::string::range $code_content 1 end]
puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 {
#OSC 10 through 17 - so called 'dynamic colours'
#can take multiple params - each successive parameter changes the next colour in the list
#- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more
#10 change text foreground colour
#11 change text background colour
#12 change text cursor colour
#13 change mouse foreground colour
#14 change mouse background colour
#15 change tektronix foreground colour
#16 change tektronix background colour
#17 change highlight colour
set params [tcl::string::range $code_content 2 end]
puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
18 {
#why is this not considered one of the dynamic colours above?
#https://www.xfree86.org/current/ctlseqs.html
#tektronix cursor color
puts stderr "overtype::renderline OSC 18 - set tektronix cursor color 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
puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction [list reset_colour_palette]
break
}
default {
puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
}
default {
@ -3791,6 +3973,23 @@ tcl::namespace::eval overtype {
#how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW
set in_overflow 1
}
set trailing_nulls 0
foreach ch [lreverse $outcols] {
if {$ch eq "\u0000"} {
incr trailing_nulls
} else {
break
}
}
if {$trailing_nulls} {
set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}]
} else {
set first_tail_null_posn -1
}
#puts stderr "first_tail_null_posn: $first_tail_null_posn"
#puts stderr "colview: [ansistring VIEW $outcols]"
foreach ch $outcols {
#puts "---- [ansistring VIEW $ch]"
@ -3865,8 +4064,17 @@ tcl::namespace::eval overtype {
}
append outstring $gxleader
append outstring $sgrleader
if {$idx+1 < $cursor_column} {
append outstring [tcl::string::map {\u0000 " "} $ch]
if {$ch eq "\u0000"} {
if {$cp437_glyphs} {
#map all nulls including at tail to space
append outstring " "
} else {
if {$trailing_nulls && $i < $first_tail_null_posn} {
append outstring " " ;#map inner nulls to space
} else {
append outstring \u0000
}
}
} else {
append outstring $ch
}
@ -3874,12 +4082,20 @@ tcl::namespace::eval overtype {
incr i
}
#flower.ans good test for null handling - reverse line building
if {![ansistring length $overflow_right]} {
set outstring [tcl::string::trimright $outstring "\u0000"]
}
set outstring [tcl::string::map {\u0000 " "} $outstring]
set overflow_right [tcl::string::trimright $overflow_right "\u0000"]
set overflow_right [tcl::string::map {\u0000 " "} $overflow_right]
#review - presence of overflow_right doesn't indicate line's trailing nulls should remain.
#The cells could have been erased?
#if {!$cp437_glyphs} {
# #if {![ansistring length $overflow_right]} {
# # set outstring [tcl::string::trimright $outstring "\u0000"]
# #}
# set outstring [tcl::string::trimright $outstring "\u0000"]
# set outstring [tcl::string::map {\u0000 " "} $outstring]
#}
#REVIEW
#set overflow_right [tcl::string::trimright $overflow_right "\u0000"]
#set overflow_right [tcl::string::map {\u0000 " "} $overflow_right]
set replay_codes ""
if {[llength $understacks] > 0} {
@ -4207,8 +4423,9 @@ tcl::namespace::eval overtype::priv {
upvar outcols o
upvar understacks ustacks
upvar understacks_gx gxstacks
upvar replay_codes_overlay replay
#ECH clears character attributes from erased character positions
#ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater.
#ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater.
if {![tcl::string::is integer -strict $count] || $count < 1} {
error "render_erasechar count must be integer >= 1"
}
@ -4223,8 +4440,9 @@ tcl::namespace::eval overtype::priv {
}
set num [expr {$end - $start + 1}]
set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space?
set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list]]]
set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]]
#DECECM ???
set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]]
set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review
return
}
proc render_setchar {i c } {

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

@ -413,6 +413,7 @@ tcl::namespace::eval punk::ansi {
tcl::namespace::export\
{a?} {a+} a \
ansistring\
ansiwrap\
convert*\
clear*\
cursor_*\
@ -722,77 +723,11 @@ tcl::namespace::eval punk::ansi {
#candidate for zig/c implementation?
proc stripansi2 {text} {
set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters
join [::punk::ansi::ta::split_at_codes $text] ""
}
proc stripansi1 {text} {
#todo - character set selection - SS2 SS3 - how are they terminated? REVIEW
variable escape_terminals ;#dict
variable ::punk::ansi::ta::standalone_code_map ;#map to empty string
set text [convert_g0 $text]
set text [tcl::string::map $standalone_code_map $text]
#e.g standalone 2 byte and 3 byte VT100(?) sequences - some of these work in wezterm
#\x1b#3 double-height letters top half
#\x1b#4 double-height letters bottom half
#\x1b#5 single-width line
#\x1b#6 double-width line
#\x1b#8 dec test fill screen
#we process char by char - line-endings whether \r\n or \n should be processed as per any other character.
#Theoretically line endings can occur within an ST payload (review e.g title?)
#ecma standard says: The character string following may consist of any bit combination, except those representing SOS or STRING TERMINATOR (ST)
set inputlist [split $text ""]
set outputlist [list]
set in_escapesequence 0
#assumption - text already 'rendered' - ie no cursor movement controls . (what about backspace and lone carriage returns - they are horizontal cursor movements)
set i 0
foreach u $inputlist {
set v [lindex $inputlist $i+1]
set uv ${u}${v}
if {$in_escapesequence eq "2b"} {
#2nd byte - done.
set in_escapesequence 0
} elseif {$in_escapesequence != 0} {
set endseq [tcl::dict::get $escape_terminals $in_escapesequence]
if {$u in $endseq} {
set in_escapesequence 0
} elseif {$uv in $endseq} {
set in_escapesequence 2b ;#flag next byte as last in sequence
}
} else {
#handle both 7-bit and 8-bit CSI and OSC
if {[regexp {^(?:\033\[|\u009b)} $uv]} {
set in_escapesequence CSI
} elseif {[regexp {^(?:\033\]|\u009d)} $uv]} {
set in_escapesequence OSC
} elseif {[regexp {^(?:\033P|\u0090)} $uv]} {
set in_escapesequence DCS
} elseif {[regexp {^(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)} $uv]} {
#SOS,PM,APC - all terminated with ST
set in_escapesequence MISC
} else {
lappend outputlist $u
}
}
incr i
}
return [join $outputlist ""]
}
#review - what happens when no terminator?
#todo - map other character sets to unicode equivs? There seems to be little support for other than the DEC special graphics set.. ISO2022 character switching not widely supported - may be best considered deprecated(?)
# convert esc(0 -> esc(B graphics sequences to single char unicode equivalents e.g box drawing set
@ -2029,7 +1964,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#[para]Return an ansi string representing a table of codes and a panel showing the colours
variable SGR_setting_map
variable SGR_colour_map
set fcposn [lsearch $args "forcecol*"]
set fcposn [lsearch $args "force*"]
set fc ""
set opt_forcecolour 0
if {$fcposn >= 0} {
@ -2409,7 +2344,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything.
set forcecolour 0
set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour
set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour
if {$fcpos >= 0} {
set forcecolour 1
set args [lremove $args $fcpos]
@ -2767,7 +2702,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything.
set forcecolour 0
set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour
set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour
if {$fcpos >=0} {
set forcecolour 1
set args [lremove $args $fcpos]
@ -3199,6 +3134,16 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
return $out
}
proc move_emitblock {row col textblock} {
#*** !doctools
#[call [fun move_emitblock] [arg row] [arg col] [arg textblock]]
set commands ""
foreach ln [split $textblock \n] {
append commands [punk::ansi::move_emit $row $col $ln]
incr row
}
return $commands
}
proc move_forward {{n 1}} {
#*** !doctools
#[call [fun move_forward] [arg n]]
@ -3315,18 +3260,90 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
#Alt screen buffer
#Alt screen buffer - smcup/rmcup ti/te
#Note \x1b\[?47h doesn't work at all in some terminals (e.g alacritty,cmd on windows and reportedly kitty)
#It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals.
#see: https://xn--rpa.cc/irl/term.html
#1049 (introduced by xterm in 1998?) considered the more modern version?
#1047,1048,1049 xterm private modes are 'composite' control sequences as replacement for original 47 sequence
#1049 - includes save cursor,switch to alt screen, clear screen
#e.g ? (below example not known to be exactly what 1049 does - but it's something similar)
#SMCUP
# \x1b7 (save cursor)
# \x1b\[?47h (switch)
# \x1b\[2J (clear screen)
#RMCUP
# \x1b\[?47l (switch back)
# \x1b8 (restore cursor)
#1047 - clear screen on the way out (ony if actually on alt screen)
proc enable_alt_screen {} {
#tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen?
#\x1b\[?1049h ;#xterm
return \x1b\[?47h
return \x1b\[?1049h
}
proc disable_alt_screen {} {
#tput rmcup outputs \x1b\[?1049l\x1b\[23\;0\;0t]
#\x1b\[?1049l
return \x1b\[?1049l
}
#47 - less widely supported(?) doesn't restore cursor or clear alt screen
proc enable_alt_screen2 {} {
return \x1b\[?47h
}
proc disable_alt_screen2 {} {
return \x1b\[?47l
}
proc term_colour_fg {colour} {
return "\x1b\]10\;$colour\x1b\\"
}
proc term_color_fg {colour} {
return "\x1b\]10\;$colour\x1b\\"
}
proc term_colour_bg {colour} {
return "\x1b\]11\;$colour\x1b\\"
}
proc term_color_bg {colour} {
return "\x1b\]11\;$colour\x1b\\"
}
proc term_colour_cursor {colour} {
return "\x1b\]12\;$colour\x1b\\"
}
proc term_color_cursor {colour} {
return "\x1b\]12\;$colour\x1b\\"
}
proc term_colour_pointer_fg {colour} {
return "\x1b\]13\;$colour\x1b\\"
}
proc term_color_pointer_fg {colour} {
return "\x1b\]13\;$colour\x1b\\"
}
proc term_colour_pointer_bg {colour} {
return "\x1b\]14\;$colour\x1b\\"
}
proc term_color_pointer_bg {colour} {
return "\x1b\]14\;$colour\x1b\\"
}
#15,16 tektronix fg, tektronix bg ???
proc term_colour_highlight_bg {colour} {
return "\x1b\]17\;$colour\x1b\\"
}
proc term_color_highlight_bg {colour} {
return "\x1b\]17\;$colour\x1b\\"
}
#18 tektronix cursor colour ???
proc term_colour_highlight_fg {colour} {
return "\x1b\]19\;$colour\x1b\\"
}
proc term_color_highlight_fg {colour} {
return "\x1b\]19\;$colour\x1b\\"
}
#22 pointer shape - there are other methods too - not known to work on windows terminal based VTs - review
proc term_colour_reset {} {
return "\x1b\]104\;\x1b\\"
}
proc term_color_reset {} {
return "\x1b\]104\;\x1b\\"
}
# -- --- ---
proc erase_line {} {
@ -4398,6 +4415,10 @@ tcl::namespace::eval punk::ansi::ta {
variable re_ansi_detect_open
expr {[regexp $re_ansi_detect_open $text]}
}
proc detect_st_open {text} {
variable re_ST_open
expr {[regexp $re_ST_open $text]}
}
#not in perl ta
proc detect_csi {text} {
@ -4672,7 +4693,8 @@ tcl::namespace::eval punk::ansi::class {
}
oo::class create base_renderer {
variable o_width
variable o_wrap o_overflow o_appendlines o_looplimit
variable o_autowrap_mode
variable o_overflow o_appendlines o_looplimit
variable o_cursor_column o_cursor_row
#variable o_render_index ;#index of input (from_ansistring) grapheme/ansi-code that *has* been rendered
@ -4690,25 +4712,33 @@ tcl::namespace::eval punk::ansi::class {
}
tcl::namespace::path $nspath
#-- --
if {[llength $args] < 2} {
error {usage: ?-width <int>? ?-wrap [1|0]? ?-overflow [1|0]? from_ansistring to_ansistring}
if {[llength $args] < 1} {
error {usage: ?-width <int>? ?-height <height>? ?-autowrap_mode [1|0]? ?-overflow [1|0]? from_ansistring}
}
lassign [lrange $args end-1 end] from_ansistring to_ansistring
#lassign [lrange $args end-1 end] from_ansistring to_ansistring
set from_ansistring [lindex $args end]
set opts [tcl::dict::create\
-width \uFFEF\
-wrap 1\
-overflow 0\
-appendlines 1\
-looplimit 15000\
-experimental {}\
-cursor_column 1\
-cursor_row 1\
-width \uFFEF\
-height \uFFEF\
-overflow 0\
-appendlines 1\
-looplimit 15000\
-experimental {}\
-cursor_column 1\
-cursor_row 1\
-insert_mode 0\
-autowrap_mode 1\
-initial_ansistring ""\
]
puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring"
set argsflags [lrange $args 0 end-2]
foreach {k v} $argsflags {
switch -- $k {
-width - -wrap - -overflow - -appendlines - -looplimit - -experimental {
-width - -height -
-overflow - -appendlines - -looplimit - -experimental -
-autowrap_mode -
-insert_mode -
-initial_ansistring {
tcl::dict::set opts $k $v
}
default {
@ -4717,8 +4747,19 @@ tcl::namespace::eval punk::ansi::class {
}
}
}
set initial_ansistring [tcl::dict::get $opts -initial_ansistring]
if {$initial_ansistring eq ""} {
set to_ansistring [punk::ansi::class::class_ansistring new ""]
} else {
#todo - verify obj vs raw string
set to_ansistring $initial_ansistring
}
puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring"
set o_width [tcl::dict::get $opts -width]
set o_wrap [tcl::dict::get $opts -wrap]
set o_height [tcl::dict::get $opts -height]
set o_autowrap_mode [tcl::dict::get $opts -autowrap_mode]
set o_insert_mode [tcl::dict::get $opts -insert_mode]
set o_overflow [tcl::dict::get $opts -overflow]
set o_appendlines [tcl::dict::get $opts -appendlines]
set o_looplimit [tcl::dict::get $opts -looplimit]
@ -4736,6 +4777,9 @@ tcl::namespace::eval punk::ansi::class {
method eval_in {script} {
eval $script
}
method renderbuf {} {
return $o_to_ansistring
}
method cursor_column {{col ""}} {
if {$col eq ""} {
return $o_cursor_column
@ -4755,6 +4799,12 @@ tcl::namespace::eval punk::ansi::class {
set o_cursor_row $row
}
#set/query cursor state
method cursor_state {args} {
lassign $args r c
return [dict create row [my cursor_row $r] column [my cursor_column $c]]
}
#consider scroll area
#we need to render to something with a concept of viewport, offscreen above,below,left,right?
method rendernext {} {
@ -4834,7 +4884,8 @@ tcl::namespace::eval punk::ansi::class {
#set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext]
}
}
#renderspace equivalent? channel based?
#todo
$o_to_ansistring append $newtext
return [tcl::dict::create type $type_rendered rendercount $rendercount start_count_unrendered $start_elements_unrendered end_count_unrendered $end_elements_unrendered]
@ -4960,11 +5011,10 @@ tcl::namespace::eval punk::ansi::class {
if {$o_renderer ne ""} {
append result \n " renderer obj: $o_renderer"
append result \n " renderer class: [info object class $o_renderer]"
}
if {$o_renderout ne ""} {
append result \n " render target ansistring: $o_renderout"
append result \n " render target has ansi : [$o_renderout has_ansi]"
append result \n " render target count : [$o_renderout count]"
set renderstring [$o_renderer renderbuf]
append result \n " render target ansistring: $renderstring"
append result \n " render target has ansi : [$renderstring has_ansi]"
append result \n " render target count : [$renderstring count]"
}
if {$verbose} {
append result \n "ansisplits listing"
@ -5052,7 +5102,8 @@ tcl::namespace::eval punk::ansi::class {
}
method strippedlength {} {
if {![llength $o_ansisplits]} {my MakeSplit}
#review
return [string length [join $o_ptlist ""]]
}
#returns the ansiless string - doesn't affect the stored state other than initialising it's internal state if it wasn't already
method stripped {} {
@ -5119,10 +5170,9 @@ tcl::namespace::eval punk::ansi::class {
if {$rtype ni $rtypes} {
error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)"
}
if {$o_renderout eq ""} {
#tell ansistring that it's a renderbuf for another ansistring? point it to the renderer or the parent ansistring?
set o_renderout [punk::ansi::class::class_ansistring new ""]
}
#if {$o_renderout eq ""} {
# set o_renderout [punk::ansi::class::class_ansistring new ""]
#}
if {$o_renderer ne ""} {
set oinfo [info object class $o_renderer]
set tail [tcl::namespace::tail $oinfo]
@ -5130,13 +5180,15 @@ tcl::namespace::eval punk::ansi::class {
if {$rtype ne $currenttype} {
puts "switch rendertype from $currenttype to $rtype - destroying renderer and creating a new one"
$o_renderer destroy ;#what happens to data in target ansistring obj? when does it make sense to keep output and keep rendering vs clearing?
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
#set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]]
} else {
return $currenttype
}
} else {
puts "creating first renderer"
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
#set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]]
}
}
#--- progressive rendering buffer - another ansistring object
@ -5149,10 +5201,13 @@ tcl::namespace::eval punk::ansi::class {
return $o_renderwidth
}
#re-render if needed?
puts stderr "renderwidth todo? re-render?"
set o_renderwidth $rw
}
method renderer {} {
return $o_renderer
}
method render_state {} {
#? report state of render.. we will primarily be using plaintext/ansisequence as the chunk/operation boundary
#but - as we can append char sequences directly to the tail split - it's not enough to track which split element we have rendered - but we also need how many graphemes or code sequences we are into the last split.
@ -5160,10 +5215,36 @@ tcl::namespace::eval punk::ansi::class {
}
method renderbuf {} {
#get the underlying renderobj - if any
return $o_renderout ;#also class_ansistring
#return $o_renderout ;#also class_ansistring
return [$o_renderer renderbuf]
}
method render {} {
method render {{maxgraphemes ""}} {
#full render - return buffer ansistring
set do_render 1
set grapheme_count 0
set other_count 0
if {$maxgraphemes eq ""} {
while {$do_render} {
set rendition [my rendernext]
set do_render [dict get $rendition rendercount]
if {[dict get $rendition type] eq "g"} {
incr grapheme_count $do_render
} else {
incr other_count $do_render
}
}
} else {
while {$do_render && $grapheme_count <= $maxgraphemes} {
set rendition [my rendernext]
set do_render [dict get $rendition rendercount]
if {[dict get $rendition type] eq "g"} {
incr grapheme_count $do_render
} else {
incr other_count $do_render
}
}
}
return [dict create graphemes $grapheme_count other $other_count]
}
method rendernext {} {
#render next available pt/code chunk only - not to end of available input
@ -5198,6 +5279,13 @@ tcl::namespace::eval punk::ansi::class {
#i.e a 'rendered' ANSI string should contain just ANSI SGR character attributes and linefeeds for rows
#Knowing which is which can be helpful as far as use of any methods which use the concepts of terminal row/column
#like Tcl's append class_ansistring append returns the result directly - which for ANSI - can be inconvenient in the terminal
#class_ansistring append_string is a convenience wrapper to avoid returning the raw result
method append_string {args} {
my append {*}$args
return
}
#analagous to Tcl string append
#MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient
method append {args} {
@ -5369,7 +5457,7 @@ tcl::namespace::eval punk::ansi::class {
}
#method append_and_render - append and render up to end of appended data at same time
#method append_and_render? - append and render up to end of appended data at same time
method view {args} {
if {$o_string eq ""} {

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

@ -864,6 +864,7 @@ namespace eval punk::console {
#Turning ansi off only stops new ansi being generated - but what about codes stored in configurations of existing elements such as tables/frames?
#It will stop underlines/bold/reverse as well as SGR colours
#what about ansi movement codes etc?
#we already have colour on|off which disables SGR codes in a+ etc as well as stderr/stdout channel transforms
proc ansi {{onoff {}}} {
variable ansi_wanted
if {[string length $onoff]} {
@ -891,6 +892,7 @@ namespace eval punk::console {
}
}
catch {punk::repl::reset_prompt}
puts stderr "::punk::console::ansi - use 'colour' command to turn SGR codes on/off"
return [expr {$ansi_wanted}]
}
@ -1295,10 +1297,10 @@ namespace eval punk::console {
if {![catch {twapi::set_console_title $windowtitle} result]} {
return $windowtitle
} else {
error "punk::console::titleset failed to set title - try punk::console::ansi::titleset"
error "punk::console::local::titleset failed to set title - try punk::console::ansi::titleset"
}
} else {
error "punk::console::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset"
error "punk::console::local::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset"
}
}
proc titleget {} {
@ -1306,12 +1308,12 @@ namespace eval punk::console {
if {![catch {twapi::get_console_title} result]} {
return $result
} else {
error "punk::console::titleset failed to set title - ensure twapi is available"
error "punk::console::local::titleset failed to set title - ensure twapi is available"
}
} else {
#titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title
# won't work on all platforms/terminals - but may be worth implementing
error "punk::console::titleget has no local mechanism to get the window title on this platform."
# won't work on all platforms/terminals - but may be worth implementing (for overtype::renderspace / frames etc)
error "punk::console::local::titleget has no local mechanism to get the window title on this platform."
}
}
}
@ -1327,7 +1329,7 @@ namespace eval punk::console {
if { $ansi_wanted <= 0} {
punk::console::local::titleset $windowtitle
} else {
tailcall ansi::titleset $windowtitle
ansi::titleset $windowtitle
}
}
#no known pure-ansi solution
@ -1486,8 +1488,6 @@ namespace eval punk::console {
namespace import ansi::insert_lines
namespace import ansi::delete_lines
interp alias {} smcup {} ::punk::console::enable_alt_screen
interp alias {} rmcup {} ::punk::console::disable_alt_screen
#experimental
proc rhs_prompt {col text} {
@ -1881,12 +1881,6 @@ namespace eval punk::console {
interp alias {} colour {} punk::console::colour
interp alias {} ansi {} punk::console::ansi
interp alias {} color {} punk::console::colour
interp alias {} a+ {} punk::console::code_a+
interp alias {} a {} punk::console::code_a
interp alias {} a? {} punk::console::code_a?

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

@ -1561,7 +1561,8 @@ tcl::namespace::eval punk::ns {
#set name [string trim $name :]
#set origin [namespace origin ${upns}::$name]
set origin [nseval $targetns [list ::namespace origin $name]]
set origin [nseval $targetns [list ::namespace origin $name]]
set resolved [nseval $targetns [list ::namespace which $name]]
#An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases!
if {$origin ni [info procs $origin]} {
@ -1613,7 +1614,8 @@ tcl::namespace::eval punk::ns {
}
lappend argl $a
}
list proc [nsjoin ${targetns} $name] $argl $body
#list proc [nsjoin ${targetns} $name] $argl $body
list proc $resolved $argl $body
}

BIN
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm

Binary file not shown.

37
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm

@ -4041,6 +4041,9 @@ tcl::namespace::eval textblock {
(default 0 if no existing -table supplied)"
-table -default "" -type string -help "existing table object to use"
-headers -default "" -help "list of header values. Must match number of columns"
-show_header -default "" -help "Whether to show a header row.
Leave as empty string for unspecified/automatic,
in which case it will display only if -headers list was supplied."
-action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied
if append is chosen the new values will always start at the first column"
-columns -default "" -type integer -help "Number of table columns
@ -4101,11 +4104,34 @@ tcl::namespace::eval textblock {
}
} else {
set is_new_table 1
set headers {}
if {[tcl::dict::get $opts -headers] ne ""} {
set headers [dict get $opts -headers]
if {[tcl::dict::get $opts -show_header] eq ""} {
set show_header 1
} else {
set show_header [tcl::dict::get $opts -show_header]
}
} else {
if {[tcl::dict::get $opts -show_header] eq ""} {
set show_header 0
} else {
set show_header [tcl::dict::get $opts -show_header]
}
}
if {[tcl::string::is integer -strict $opt_columns]} {
set cols $opt_columns
if {[llength $headers] && $cols != [llength $headers]} {
error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $headers])"
}
} else {
#review
set cols 2 ;#seems a reasonable default
if {[llength $headers]} {
set cols [llength $headers]
} else {
set cols 2 ;#seems a reasonable default
}
}
#defaults for new table only
if {[tcl::dict::get $opts -frametype] eq ""} {
@ -4123,15 +4149,6 @@ tcl::namespace::eval textblock {
if {[tcl::dict::get $opts -show_hseps] eq ""} {
tcl::dict::set opts -show_hseps 0
}
set headers {}
set show_header 0
if {[tcl::dict::get $opts -headers] ne ""} {
set headers [dict get $opts -headers]
if {[llength $headers] ne $cols} {
error "list_as_table number of headers ([llength $headers]) must match number of columns ($cols)"
}
set show_header 1
}
set t [textblock::class::table new\
-show_header $show_header\

3357
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.1.tm

File diff suppressed because it is too large Load Diff

246
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/uuid-1.0.8.tm

@ -0,0 +1,246 @@
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# UUIDs are 128 bit values that attempt to be unique in time and space.
#
# Reference:
# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt
#
# uuid: scheme:
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html
#
# Usage: uuid::uuid generate
# uuid::uuid equal $idA $idB
package require Tcl 8.5 9
namespace eval uuid {
variable accel
array set accel {critcl 0}
namespace export uuid
variable uid
if {![info exists uid]} {
set uid 1
}
proc K {a b} {set a}
}
###
# Optimization
# Caches machine info after the first pass
###
proc ::uuid::generate_tcl_machinfo {} {
variable machinfo
if {[info exists machinfo]} {
return $machinfo
}
lappend machinfo [clock seconds]; # timestamp
lappend machinfo [clock clicks]; # system incrementing counter
lappend machinfo [info hostname]; # spatial unique id (poor)
lappend machinfo [pid]; # additional entropy
lappend machinfo [array get ::tcl_platform]
###
# If we have /dev/urandom just stream 128 bits from that
###
if {[file exists /dev/urandom]} {
set fin [open /dev/urandom r]
fconfigure $fin -encoding binary
binary scan [read $fin 128] H* machinfo
close $fin
} elseif {[catch {package require nettool}]} {
# More spatial information -- better than hostname.
# bug 1150714: opening a server socket may raise a warning messagebox
# with WinXP firewall, using ipconfig will return all IP addresses
# including ipv6 ones if available. ipconfig is OK on win98+
if {[string equal $::tcl_platform(platform) "windows"]} {
catch {exec ipconfig} config
lappend machinfo $config
} else {
catch {
set s [socket -server void -myaddr [info hostname] 0]
K [fconfigure $s -sockname] [close $s]
} r
lappend machinfo $r
}
if {[package provide Tk] != {}} {
lappend machinfo [winfo pointerxy .]
lappend machinfo [winfo id .]
}
} else {
###
# If the nettool package works on this platform
# use the stream of hardware ids from it
###
lappend machinfo {*}[::nettool::hwid_list]
}
return $machinfo
}
# Generates a binary UUID as per the draft spec. We generate a pseudo-random
# type uuid (type 4). See section 3.4
#
proc ::uuid::generate_tcl {} {
package require md5 2
variable uid
set tok [md5::MD5Init]
md5::MD5Update $tok [incr uid]; # package incrementing counter
foreach string [generate_tcl_machinfo] {
md5::MD5Update $tok $string
}
set r [md5::MD5Final $tok]
binary scan $r c* r
# 3.4: set uuid versioning fields
lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}]
lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}]
return [binary format c* $r]
}
if {[string equal $tcl_platform(platform) "windows"]
&& [package provide critcl] != {}} {
namespace eval uuid {
critcl::ccode {
#define WIN32_LEAN_AND_MEAN
#define STRICT
#include <windows.h>
#include <ole2.h>
typedef long (__stdcall *LPFNUUIDCREATE)(UUID *);
typedef const unsigned char cu_char;
}
critcl::cproc generate_c {Tcl_Interp* interp} ok {
HRESULT hr = S_OK;
int r = TCL_OK;
UUID uuid = {0};
HMODULE hLib;
LPFNUUIDCREATE lpfnUuidCreate = NULL;
hLib = LoadLibraryA(("rpcrt4.dll"));
if (hLib)
lpfnUuidCreate = (LPFNUUIDCREATE)
GetProcAddress(hLib, "UuidCreate");
if (lpfnUuidCreate) {
Tcl_Obj *obj;
lpfnUuidCreate(&uuid);
obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid));
Tcl_SetObjResult(interp, obj);
} else {
Tcl_SetResult(interp, "error: failed to create a guid",
TCL_STATIC);
r = TCL_ERROR;
}
return r;
}
}
}
# Convert a binary uuid into its string representation.
#
proc ::uuid::tostring {uuid} {
binary scan $uuid H* s
foreach {a b} {0 7 8 11 12 15 16 19 20 end} {
append r [string range $s $a $b] -
}
return [string tolower [string trimright $r -]]
}
# Convert a string representation of a uuid into its binary format.
#
proc ::uuid::fromstring {uuid} {
return [binary format H* [string map {- {}} $uuid]]
}
# Compare two uuids for equality.
#
proc ::uuid::equal {left right} {
set l [fromstring $left]
set r [fromstring $right]
return [string equal $l $r]
}
# Call our generate uuid implementation
proc ::uuid::generate {} {
variable accel
if {$accel(critcl)} {
return [generate_c]
} else {
return [generate_tcl]
}
}
# uuid generate -> string rep of a new uuid
# uuid equal uuid1 uuid2
#
proc uuid::uuid {cmd args} {
switch -exact -- $cmd {
generate {
if {[llength $args] != 0} {
return -code error "wrong # args:\
should be \"uuid generate\""
}
return [tostring [generate]]
}
equal {
if {[llength $args] != 2} {
return -code error "wrong \# args:\
should be \"uuid equal uuid1 uuid2\""
}
return [eval [linsert $args 0 equal]]
}
default {
return -code error "bad option \"$cmd\":\
must be generate or equal"
}
}
}
# -------------------------------------------------------------------------
# LoadAccelerator --
#
# This package can make use of a number of compiled extensions to
# accelerate the digest computation. This procedure manages the
# use of these extensions within the package. During normal usage
# this should not be called, but the test package manipulates the
# list of enabled accelerators.
#
proc ::uuid::LoadAccelerator {name} {
variable accel
set r 0
switch -exact -- $name {
critcl {
if {![catch {package require tcllibc}]} {
set r [expr {[info commands ::uuid::generate_c] != {}}]
}
}
default {
return -code error "invalid accelerator package:\
must be one of [join [array names accel] {, }]"
}
}
set accel($name) $r
}
# -------------------------------------------------------------------------
# Try and load a compiled extension to help.
namespace eval ::uuid {
variable e {}
foreach e {critcl} {
if {[LoadAccelerator $e]} break
}
unset e
}
package provide uuid 1.0.8
# -------------------------------------------------------------------------
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:

9
src/testansi/palettes/AppleII.ans

@ -0,0 +1,9 @@
]4;0;rgb:00/00/00]4;1;rgb:e3/1e/60]4;2;rgb:00/a3/60]4;3;rgb:60/72/03]4;4;rgb:60/4e/bd]4;5;rgb:ff/44/fd]4;6;rgb:d0/c3/ff]4;7;rgb:9c/9c/9c]4;8;rgb:9c/9c/9c]4;9;rgb:ff/6a/3c]4;10;rgb:14/f5/3c]4;11;rgb:d0/dd/8d]4;12;rgb:14/cf/fd]4;13;rgb:ff/a0/d0]4;14;rgb:72/ff/d0]4;15;rgb:ff/ff/ff
Apple II colors palette
Change the console palette to colors from the Apple II colors palette,
while trying to keep colors indexes similar to CGA.
This is designed to bring back memories when seeing ANSI-art in Apple II
colors, but isn't a compatible palette and doesn't match Apple II indexes.
by Philippe Majerus (www.phm.lu)

12
src/testansi/palettes/Solarized.ans

@ -0,0 +1,12 @@
]4;0;rgb:07/36/42]4;1;rgb:dc/32/2f]4;2;rgb:85/99/00]4;3;rgb:b5/89/00]4;4;rgb:26/8b/d2]4;5;rgb:d3/36/82]4;6;rgb:2a/a1/98]4;7;rgb:ee/e8/d5]4;8;rgb:00/2b/36]4;9;rgb:cb/4b/16]4;10;rgb:58/6e/75]4;11;rgb:65/7b/83]4;12;rgb:83/94/96]4;13;rgb:6c/71/c4]4;14;rgb:93/a1/a1]4;15;rgb:fd/f6/e3
Solarized colors palette
Change the console palette to the Solarized palette designed by Ethan Schoonover
Solarized is a palette that does not respect the console and ANSI
palettes, but provides replacement monotones and accent colors
that reduces contrasting brightness while preserving contrasting
hues, making text more comfortable to read.
Credits: Ethan Schoonover (http://ethanschoonover.com/solarized)
ANSI/VT file by Philippe Majerus (www.phm.lu)

13
src/testansi/palettes/Solarized_light.ans

@ -0,0 +1,13 @@
]4;0;rgb:ee/e8/d5]4;1;rgb:dc/32/2f]4;2;rgb:85/99/00]4;3;rgb:b5/89/00]4;4;rgb:26/8b/d2]4;5;rgb:d3/36/82]4;6;rgb:2a/a1/98]4;7;rgb:07/36/42]4;8;rgb:fd/f6/e3]4;9;rgb:cb/4b/16]4;10;rgb:93/a1/a1]4;11;rgb:83/94/96]4;12;rgb:65/7b/83]4;13;rgb:6c/71/c4]4;14;rgb:58/6e/75]4;15;rgb:00/2b/36
Solarized light colors palette
Change the console palette to the light background version of
the Solarized palette designed by Ethan Schoonover.
This does not respect the console and ANSI palette, but instead
reverses background tones and content tones so existing scripts
designed for light content on dark background automatically
show as light background. Accent colors are left intact.
Credits: Ethan Schoonover (http://ethanschoonover.com/solarized)
ANSI/VT file by Philippe Majerus (www.phm.lu)

6
src/testansi/palettes/VSCode.ans

@ -0,0 +1,6 @@
]4;0;rgb:1e/1e/1e]4;1;rgb:cd/31/31]4;2;rgb:0d/bc/79]4;3;rgb:e5/e5/10]4;4;rgb:24/72/c8]4;5;rgb:bc/3f/bc]4;6;rgb:11/a8/cd]4;7;rgb:cc/cc/cc]4;8;rgb:66/66/66]4;9;rgb:f1/4c/4c]4;10;rgb:23/d1/8b]4;11;rgb:f5/f5/43]4;12;rgb:3b/8e/ea]4;13;rgb:d6/70/d6]4;14;rgb:29/b8/db]4;15;rgb:e5/e5/e5
VSCode colors palette
Change the console palette to the standard Dark+ palette used in Visual Studio Code.
by Philippe Majerus (www.phm.lu)

6
src/testansi/palettes/Windows.ans

@ -0,0 +1,6 @@
]4;0;rgb:0c/0c/0c]4;1;rgb:c5/0f/1f]4;2;rgb:13/a1/0e]4;3;rgb:c1/9c/00]4;4;rgb:00/37/da]4;5;rgb:88/17/98]4;6;rgb:3a/96/dd]4;7;rgb:cc/cc/cc]4;8;rgb:76/76/76]4;9;rgb:e7/48/56]4;10;rgb:16/c6/0c]4;11;rgb:f9/f1/a5]4;12;rgb:3b/78/ff]4;13;rgb:b4/00/9e]4;14;rgb:61/d6/d6]4;15;rgb:f2/f2/f2
Windows colors palette
The new Windows console palette from Windows 10 Ver. 1709 and later.
by Philippe Majerus (www.phm.lu)

7
src/testansi/palettes/windows_legacy.ans

@ -0,0 +1,7 @@
]4;0;rgb:00/00/00]4;1;rgb:80/00/00]4;2;rgb:00/80/00]4;3;rgb:80/80/00]4;4;rgb:00/00/80]4;5;rgb:80/00/80]4;6;rgb:00/80/80]4;7;rgb:c0/c0/c0]4;8;rgb:80/80/80]4;9;rgb:ff/00/00]4;10;rgb:00/ff/00]4;11;rgb:ff/ff/00]4;12;rgb:00/00/ff]4;13;rgb:ff/00/ff]4;14;rgb:00/ff/ff]4;15;rgb:ff/ff/ff
Windows legacy colors palette
Change the console palette to the original Windows conhost palette.
(The standard Windows console palette finally changed in Windows 10 Ver. 1709)
by Philippe Majerus (www.phm.lu)

458
src/vendormodules/overtype-1.6.5.tm

@ -233,7 +233,6 @@ tcl::namespace::eval overtype {
-width \uFFEF\
-height \uFFEF\
-startcolumn 1\
-wrap 0\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
@ -243,11 +242,13 @@ tcl::namespace::eval overtype {
-exposed1 \uFFFD\
-exposed2 \uFFFD\
-experimental 0\
-cp437 1\
-cp437 0\
-looplimit \uFFEF\
-crm_mode 0\
-reverse_mode 0\
-insert_mode 0\
-wrap 0\
-info 0\
-console {stdin stdout stderr}\
]
#expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally..
@ -263,14 +264,19 @@ tcl::namespace::eval overtype {
#-ellipsis args not used if -wrap is true
foreach {k v} $argsflags {
switch -- $k {
-looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace
-looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace
- -transparent - -exposed1 - -exposed2 - -experimental
- -expand_right - -appendlines
- -reverse_mode - -crm_mode - -insert_mode
- -cp437
- -console {
- -info - -console {
tcl::dict::set opts $k $v
}
-wrap - -autowrap_mode {
#temp alias -autowrap_mode for consistency with renderline
#todo -
tcl::dict::set opts -wrap $v
}
default {
error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]"
}
@ -280,10 +286,6 @@ tcl::namespace::eval overtype {
# -- --- --- --- --- ---
#review - expand_left for RTL text?
set opt_expand_right [tcl::dict::get $opts -expand_right]
#####
# review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?.
set opt_wrap [tcl::dict::get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo)
#####
#for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line.
set opt_width [tcl::dict::get $opts -width]
set opt_height [tcl::dict::get $opts -height]
@ -298,50 +300,34 @@ tcl::namespace::eval overtype {
set opt_crm_mode [tcl::dict::get $opts -crm_mode]
set opt_reverse_mode [tcl::dict::get $opts -reverse_mode]
set opt_insert_mode [tcl::dict::get $opts -insert_mode]
#####
# review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?.
set opt_autowrap_mode [tcl::dict::get $opts -wrap]
#??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo)
#####
# -- --- --- --- --- ---
set opt_cp437 [tcl::dict::get $opts -cp437]
set opt_info [tcl::dict::get $opts -info]
#initial state for renderspace 'terminal' reset
set initial_state [dict create\
-width $opt_width\
-height $opt_height\
-crm_mode $opt_crm_mode\
-reverse_mode $opt_reverse_mode\
-insert_mode $opt_insert_mode\
-cp437 $opt_cp437\
]
# ----------------------------
# -experimental dev flag to set flags etc
# ----------------------------
set data_mode 0
set info_mode 0
set edit_mode 0
set opt_experimental [tcl::dict::get $opts -experimental]
foreach o $opt_experimental {
switch -- $o {
old_mode {
set info_mode 1
}
data_mode {
set data_mode 1
}
info_mode {
set info_mode 1
}
edit_mode {
set edit_mode 1
}
}
}
# ----------------------------
#modes
set insert_mode $opt_insert_mode ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l
set autowrap_mode $opt_wrap
set reverse_mode $opt_reverse_mode
set crm_mode $opt_crm_mode
set underblock [tcl::string::map {\r\n \n} $underblock]
@ -367,6 +353,20 @@ tcl::namespace::eval overtype {
set renderwidth $opt_width
set renderheight $opt_height
}
#initial state for renderspace 'terminal' reset
set initial_state [dict create\
renderwidth $renderwidth\
renderheight $renderheight\
crm_mode $opt_crm_mode\
reverse_mode $opt_reverse_mode\
insert_mode $opt_insert_mode\
autowrap_mode $opt_autowrap_mode\
cp437 $opt_cp437\
]
#modes
#e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l
#opt_startcolumn ?? - DECSLRM ?
set vtstate $initial_state
# -- --- --- ---
#REVIEW - do we need ansi resets in the underblock?
@ -494,50 +494,55 @@ tcl::namespace::eval overtype {
}
#review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary -
#but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l
set renderargs [list -experimental $opt_experimental\
-cp437 $opt_cp437\
-info 1\
-crm_mode $crm_mode\
-insert_mode $insert_mode\
-autowrap_mode $autowrap_mode\
-reverse_mode $reverse_mode\
-cursor_restore_attributes $cursor_saved_attributes\
-transparent $opt_transparent\
-width $renderwidth\
-exposed1 $opt_exposed1\
-exposed2 $opt_exposed2\
-expand_right $opt_expand_right\
-cursor_column $col\
-cursor_row $row\
set renderargs [list -experimental $opt_experimental\
-cp437 $opt_cp437\
-info 1\
-crm_mode [tcl::dict::get $vtstate crm_mode]\
-insert_mode [tcl::dict::get $vtstate insert_mode]\
-autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\
-reverse_mode [tcl::dict::get $vtstate reverse_mode]\
-cursor_restore_attributes $cursor_saved_attributes\
-transparent $opt_transparent\
-width [tcl::dict::get $vtstate renderwidth]\
-exposed1 $opt_exposed1\
-exposed2 $opt_exposed2\
-expand_right $opt_expand_right\
-cursor_column $col\
-cursor_row $row\
$undertext\
$overtext\
]
set LASTCALL $renderargs
set rinfo [renderline {*}$renderargs]
set instruction [tcl::dict::get $rinfo instruction]
set insert_mode [tcl::dict::get $rinfo insert_mode]
set autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;#
set reverse_mode [tcl::dict::get $rinfo reverse_mode]
set instruction [tcl::dict::get $rinfo instruction]
tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode]
tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode]
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;#
tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode]
#how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack?
# - review - the answer is probably that we don't need to - it is set/reset only during application of overtext
set crm_mode [tcl::dict::get $rinfo crm_mode]
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set overflow_right_column [tcl::dict::get $rinfo overflow_right_column]
set unapplied [tcl::dict::get $rinfo unapplied]
set unapplied_list [tcl::dict::get $rinfo unapplied_list]
set post_render_col [tcl::dict::get $rinfo cursor_column]
set post_render_row [tcl::dict::get $rinfo cursor_row]
set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position]
set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes]
set visualwidth [tcl::dict::get $rinfo visualwidth]
set insert_lines_above [tcl::dict::get $rinfo insert_lines_above]
set insert_lines_below [tcl::dict::get $rinfo insert_lines_below]
tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay]
#Note carefully the difference betw overflow_right and unapplied.
#overflow_right may need to be included in next run before the unapplied data
#overflow_right most commonly has data when in insert_mode
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set overflow_right_column [tcl::dict::get $rinfo overflow_right_column]
set unapplied [tcl::dict::get $rinfo unapplied]
set unapplied_list [tcl::dict::get $rinfo unapplied_list]
set post_render_col [tcl::dict::get $rinfo cursor_column]
set post_render_row [tcl::dict::get $rinfo cursor_row]
set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position]
set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes]
set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line
set insert_lines_above [tcl::dict::get $rinfo insert_lines_above]
set insert_lines_below [tcl::dict::get $rinfo insert_lines_below]
tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay]
#lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay]
set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]
if {0 && $reverse_mode} {
if {0 && [tcl::dict::get $vtstate reverse_mode]} {
#test branch - todo - prune
puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered"
#review
@ -593,19 +598,29 @@ tcl::namespace::eval overtype {
#todo - handle potential insertion mode as above for cursor restore?
#keeping separate branches for debugging - review and merge as appropriate when stable
tcl::dict::incr instruction_stats $instruction
switch -- $instruction {
set instruction_type [lindex $instruction 0] ;#some instructions have params
tcl::dict::incr instruction_stats $instruction_type
switch -- $instruction_type {
reset {
#reset the 'renderspace terminal' (not underlying terminal)
set row 1
set col 1
set vtstate [tcl::dict::merge $vtstate $initial_state]
#todo - clear screen
}
{} {
#end of supplied line input
#lf included in data
set row $post_render_row
set col $post_render_col
if {![llength $unapplied_list]} {
if {$overflow_right ne ""} {
incr row
}
} else {
puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)"
}
set col $opt_startcolumn
}
up {
@ -708,17 +723,18 @@ tcl::namespace::eval overtype {
puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]"
set sub_info [overtype::renderline -info 1\
-width $renderwidth\
-insert_mode $insert_mode\
-autowrap_mode $autowrap_mode\
set sub_info [overtype::renderline\
-info 1\
-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]\
""\
$overflow_right\
]
set foldline [tcl::dict::get $sub_info result]
set insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
set autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
set foldline [tcl::dict::get $sub_info result]
tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
linsert outputlines $renderedrow $foldline
#review - row & col set by restore - but not if there was no save..
}
@ -745,6 +761,53 @@ tcl::namespace::eval overtype {
set col $post_render_col
#overflow + unapplied?
}
clear_and_move {
#e.g 2J
if {$post_render_row > [llength $outputlines]} {
set row [llength $outputlines]
} else {
set row $post_render_row
}
set col $post_render_col
set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant
set clearedlines [list]
foreach ln $outputlines {
lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m
if 0 {
set lineparts [punk::ansi::ta::split_codes $ln]
set numcells 0
foreach {pt _code} $lineparts {
if {$pt ne ""} {
foreach grapheme [punk::char::grapheme_split $pt] {
switch -- $grapheme {
" " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? -
a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y -
z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
incr numcells 1
}
default {
if {$grapheme eq "\u0000"} {
incr numcells 1
} else {
incr numcells [grapheme_width_cached $grapheme]
}
}
}
}
}
}
#replays/resets each line
lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m
}
}
set outputlines $clearedlines
#todo - determine background/default to be in effect - DECECM ?
puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]"
#lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0]
}
lf_start {
#raw newlines
# ----------------------
@ -780,27 +843,48 @@ tcl::namespace::eval overtype {
append rendered $overflow_right
set overflow_right ""
} else {
#review - we should really make renderline do the work...?
set overflow_width [punk::ansi::printing_length $overflow_right]
if {$visualwidth + $overflow_width <= $renderwidth} {
append rendered $overflow_right
set overflow_right ""
} else {
if {$visualwidth < $renderwidth} {
set graphemes [punk::char::grapheme_split $overflow_width]
set add ""
set addlen $visualwidth
set remaining_overflow $graphemes
foreach g $graphemes {
set w [overtype::grapheme_width_cached]
if {$addlen + $w <= $renderwidth} {
append add $g
incr addlen $w
lpop remaining_overflow
} else {
break
}
if {[tcl::dict::get $vtstate autowrap_mode]} {
set outputlines [linsert $outputlines $renderedrow $overflow_right]
set overflow_right ""
set row [expr {$renderedrow + 2}]
} else {
set overflow_right "" ;#abandon
}
if {0 && $visualwidth < $renderwidth} {
puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth"
error "incomplete - abandon?"
set overflowparts [punk::ansi::ta::split_codes $overflow_right]
set remaining_overflow $overflowparts
set filled 0
foreach {pt code} $overflowparts {
lpop remaining_overflow 0
if {$pt ne ""} {
set graphemes [punk::char::grapheme_split $pt]
set add ""
set addlen $visualwidth
foreach g $graphemes {
set w [overtype::grapheme_width_cached $g]
if {$addlen + $w <= $renderwidth} {
append add $g
incr addlen $w
} else {
set filled 1
break
}
}
append rendered $add
}
if {!$filled} {
lpop remaining_overflow 0 ;#pop code
}
}
append rendered $add
set overflow_right [join $remaining_overflow ""]
}
}
@ -829,14 +913,16 @@ tcl::namespace::eval overtype {
#we may also have other control sequences that came after col 80 e.g cursor save
if 0 {
set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]]
set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs]
set rhs ""
set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]]
set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs]
set rhs ""
#assertion - there should be no overflow..
puts $lhs
#assertion - there should be no overflow..
puts $lhs
}
if {![tcl::dict::get $vtstate insert_mode]} {
assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode
}
assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right
set row $post_render_row
#set row $renderedrow
@ -981,7 +1067,7 @@ tcl::namespace::eval overtype {
#normal single-width grapheme overflow
#puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]"
set row $post_render_row ;#renderline will not advance row when reporting overflow char
if {$autowrap_mode} {
if {[tcl::dict::get $vtstate autowrap_mode]} {
incr row
set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ??
} else {
@ -1014,7 +1100,7 @@ tcl::namespace::eval overtype {
#2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts
#todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc
if {$autowrap_mode} {
if {[tcl::dict::get $vtstate autowrap_mode]} {
if {$renderwidth < 2} {
#edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character
set idx 0
@ -1055,6 +1141,14 @@ tcl::namespace::eval overtype {
set row $post_render_row
set col $post_render_col
}
set_window_title {
set newtitle [lindex $instruction 1]
puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'"
#
}
reset_colour_palette {
puts stderr "overtype::renderspace instruction '$instruction' unimplemented"
}
default {
puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'"
}
@ -1062,7 +1156,7 @@ tcl::namespace::eval overtype {
}
if {!$opt_expand_right && !$autowrap_mode} {
if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} {
#not allowed to overflow column or wrap therefore we get overflow data to truncate
if {[tcl::dict::get $opts -ellipsis]} {
set show_ellipsis 1
@ -1160,11 +1254,22 @@ tcl::namespace::eval overtype {
}
set result [join $outputlines \n]
if {$info_mode} {
if {!$opt_info} {
return $result
} else {
#emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window?
#append result \n$instruction_stats\n
set inforesult [dict create\
result $result\
last_instruction $instruction\
instruction_stats $instruction_stats\
]
if {$opt_info == 2} {
return [pdict -channel none inforesult]
} else {
return $inforesult
}
}
return $result
}
#todo - left-right ellipsis ?
@ -2368,14 +2473,22 @@ tcl::namespace::eval overtype {
} else {
#linefeed occurred in middle or at end of text
#puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx"
incr cursor_row
if {$idx == -1 || $overflow_idx > $idx} {
#don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
if {$insert_mode == 0} {
incr cursor_row
if {$idx == -1 || $overflow_idx > $idx} {
#don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
}
set instruction lf_mid
priv::render_unapplied $overlay_grapheme_control_list $gci
break
} else {
incr cursor_row
#don't adjust the overflow_idx
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction lf_mid
break ;# could have overdata following the \n - don't keep processing
}
set instruction lf_mid
priv::render_unapplied $overlay_grapheme_control_list $gci
break
}
}
@ -3077,8 +3190,11 @@ tcl::namespace::eval overtype {
set idx [expr {$cursor_column -1}]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
if {[llength $outcols]} {
priv::render_erasechar 0 [llength $outcols]
}
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction move
set instruction clear_and_move
break
}
3 {
@ -3749,6 +3865,72 @@ tcl::namespace::eval overtype {
}
7OSC - 8OSC {
# OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit
if {[tcl::string::index $codenorm end] eq "\007"} {
set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007
} else {
set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\
}
set first_colon [tcl::string::first {;} $code_content]
if {$first_colon == -1} {
#there probably should always be a colon - but we'll try to make sense of it without
set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007
} else {
set osc_code [tcl::string::range $code_content 0 $first_colon-1]
}
switch -exact -- $osc_code {
2 {
set newtitle [tcl::string::range $code_content 2 end]
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction [list set_window_title $newtitle]
break
}
4 {
#OSC 4 - set colour palette
#can take multiple params
#e.g \x1b\]4\;1\;red\;2\;green\x1b\\
set params [tcl::string::range $code_content 1 end]
puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 {
#OSC 10 through 17 - so called 'dynamic colours'
#can take multiple params - each successive parameter changes the next colour in the list
#- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more
#10 change text foreground colour
#11 change text background colour
#12 change text cursor colour
#13 change mouse foreground colour
#14 change mouse background colour
#15 change tektronix foreground colour
#16 change tektronix background colour
#17 change highlight colour
set params [tcl::string::range $code_content 2 end]
puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
18 {
#why is this not considered one of the dynamic colours above?
#https://www.xfree86.org/current/ctlseqs.html
#tektronix cursor color
puts stderr "overtype::renderline OSC 18 - set tektronix cursor color 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
puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction [list reset_colour_palette]
break
}
default {
puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
}
default {
@ -3791,6 +3973,23 @@ tcl::namespace::eval overtype {
#how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW
set in_overflow 1
}
set trailing_nulls 0
foreach ch [lreverse $outcols] {
if {$ch eq "\u0000"} {
incr trailing_nulls
} else {
break
}
}
if {$trailing_nulls} {
set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}]
} else {
set first_tail_null_posn -1
}
#puts stderr "first_tail_null_posn: $first_tail_null_posn"
#puts stderr "colview: [ansistring VIEW $outcols]"
foreach ch $outcols {
#puts "---- [ansistring VIEW $ch]"
@ -3865,8 +4064,17 @@ tcl::namespace::eval overtype {
}
append outstring $gxleader
append outstring $sgrleader
if {$idx+1 < $cursor_column} {
append outstring [tcl::string::map {\u0000 " "} $ch]
if {$ch eq "\u0000"} {
if {$cp437_glyphs} {
#map all nulls including at tail to space
append outstring " "
} else {
if {$trailing_nulls && $i < $first_tail_null_posn} {
append outstring " " ;#map inner nulls to space
} else {
append outstring \u0000
}
}
} else {
append outstring $ch
}
@ -3874,12 +4082,20 @@ tcl::namespace::eval overtype {
incr i
}
#flower.ans good test for null handling - reverse line building
if {![ansistring length $overflow_right]} {
set outstring [tcl::string::trimright $outstring "\u0000"]
}
set outstring [tcl::string::map {\u0000 " "} $outstring]
set overflow_right [tcl::string::trimright $overflow_right "\u0000"]
set overflow_right [tcl::string::map {\u0000 " "} $overflow_right]
#review - presence of overflow_right doesn't indicate line's trailing nulls should remain.
#The cells could have been erased?
#if {!$cp437_glyphs} {
# #if {![ansistring length $overflow_right]} {
# # set outstring [tcl::string::trimright $outstring "\u0000"]
# #}
# set outstring [tcl::string::trimright $outstring "\u0000"]
# set outstring [tcl::string::map {\u0000 " "} $outstring]
#}
#REVIEW
#set overflow_right [tcl::string::trimright $overflow_right "\u0000"]
#set overflow_right [tcl::string::map {\u0000 " "} $overflow_right]
set replay_codes ""
if {[llength $understacks] > 0} {
@ -4207,8 +4423,9 @@ tcl::namespace::eval overtype::priv {
upvar outcols o
upvar understacks ustacks
upvar understacks_gx gxstacks
upvar replay_codes_overlay replay
#ECH clears character attributes from erased character positions
#ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater.
#ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater.
if {![tcl::string::is integer -strict $count] || $count < 1} {
error "render_erasechar count must be integer >= 1"
}
@ -4223,8 +4440,9 @@ tcl::namespace::eval overtype::priv {
}
set num [expr {$end - $start + 1}]
set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space?
set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list]]]
set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]]
#DECECM ???
set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]]
set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review
return
}
proc render_setchar {i c } {

BIN
src/vendormodules/test/tomlish-1.1.1.tm

Binary file not shown.

1092
src/vendormodules/tomlish-1.1.1.tm

File diff suppressed because it is too large Load Diff

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

@ -233,7 +233,6 @@ tcl::namespace::eval overtype {
-width \uFFEF\
-height \uFFEF\
-startcolumn 1\
-wrap 0\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
@ -243,11 +242,13 @@ tcl::namespace::eval overtype {
-exposed1 \uFFFD\
-exposed2 \uFFFD\
-experimental 0\
-cp437 1\
-cp437 0\
-looplimit \uFFEF\
-crm_mode 0\
-reverse_mode 0\
-insert_mode 0\
-wrap 0\
-info 0\
-console {stdin stdout stderr}\
]
#expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally..
@ -263,14 +264,19 @@ tcl::namespace::eval overtype {
#-ellipsis args not used if -wrap is true
foreach {k v} $argsflags {
switch -- $k {
-looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace
-looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace
- -transparent - -exposed1 - -exposed2 - -experimental
- -expand_right - -appendlines
- -reverse_mode - -crm_mode - -insert_mode
- -cp437
- -console {
- -info - -console {
tcl::dict::set opts $k $v
}
-wrap - -autowrap_mode {
#temp alias -autowrap_mode for consistency with renderline
#todo -
tcl::dict::set opts -wrap $v
}
default {
error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]"
}
@ -280,10 +286,6 @@ tcl::namespace::eval overtype {
# -- --- --- --- --- ---
#review - expand_left for RTL text?
set opt_expand_right [tcl::dict::get $opts -expand_right]
#####
# review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?.
set opt_wrap [tcl::dict::get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo)
#####
#for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line.
set opt_width [tcl::dict::get $opts -width]
set opt_height [tcl::dict::get $opts -height]
@ -298,50 +300,34 @@ tcl::namespace::eval overtype {
set opt_crm_mode [tcl::dict::get $opts -crm_mode]
set opt_reverse_mode [tcl::dict::get $opts -reverse_mode]
set opt_insert_mode [tcl::dict::get $opts -insert_mode]
#####
# review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?.
set opt_autowrap_mode [tcl::dict::get $opts -wrap]
#??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo)
#####
# -- --- --- --- --- ---
set opt_cp437 [tcl::dict::get $opts -cp437]
set opt_info [tcl::dict::get $opts -info]
#initial state for renderspace 'terminal' reset
set initial_state [dict create\
-width $opt_width\
-height $opt_height\
-crm_mode $opt_crm_mode\
-reverse_mode $opt_reverse_mode\
-insert_mode $opt_insert_mode\
-cp437 $opt_cp437\
]
# ----------------------------
# -experimental dev flag to set flags etc
# ----------------------------
set data_mode 0
set info_mode 0
set edit_mode 0
set opt_experimental [tcl::dict::get $opts -experimental]
foreach o $opt_experimental {
switch -- $o {
old_mode {
set info_mode 1
}
data_mode {
set data_mode 1
}
info_mode {
set info_mode 1
}
edit_mode {
set edit_mode 1
}
}
}
# ----------------------------
#modes
set insert_mode $opt_insert_mode ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l
set autowrap_mode $opt_wrap
set reverse_mode $opt_reverse_mode
set crm_mode $opt_crm_mode
set underblock [tcl::string::map {\r\n \n} $underblock]
@ -367,6 +353,20 @@ tcl::namespace::eval overtype {
set renderwidth $opt_width
set renderheight $opt_height
}
#initial state for renderspace 'terminal' reset
set initial_state [dict create\
renderwidth $renderwidth\
renderheight $renderheight\
crm_mode $opt_crm_mode\
reverse_mode $opt_reverse_mode\
insert_mode $opt_insert_mode\
autowrap_mode $opt_autowrap_mode\
cp437 $opt_cp437\
]
#modes
#e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l
#opt_startcolumn ?? - DECSLRM ?
set vtstate $initial_state
# -- --- --- ---
#REVIEW - do we need ansi resets in the underblock?
@ -494,50 +494,55 @@ tcl::namespace::eval overtype {
}
#review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary -
#but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l
set renderargs [list -experimental $opt_experimental\
-cp437 $opt_cp437\
-info 1\
-crm_mode $crm_mode\
-insert_mode $insert_mode\
-autowrap_mode $autowrap_mode\
-reverse_mode $reverse_mode\
-cursor_restore_attributes $cursor_saved_attributes\
-transparent $opt_transparent\
-width $renderwidth\
-exposed1 $opt_exposed1\
-exposed2 $opt_exposed2\
-expand_right $opt_expand_right\
-cursor_column $col\
-cursor_row $row\
set renderargs [list -experimental $opt_experimental\
-cp437 $opt_cp437\
-info 1\
-crm_mode [tcl::dict::get $vtstate crm_mode]\
-insert_mode [tcl::dict::get $vtstate insert_mode]\
-autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\
-reverse_mode [tcl::dict::get $vtstate reverse_mode]\
-cursor_restore_attributes $cursor_saved_attributes\
-transparent $opt_transparent\
-width [tcl::dict::get $vtstate renderwidth]\
-exposed1 $opt_exposed1\
-exposed2 $opt_exposed2\
-expand_right $opt_expand_right\
-cursor_column $col\
-cursor_row $row\
$undertext\
$overtext\
]
set LASTCALL $renderargs
set rinfo [renderline {*}$renderargs]
set instruction [tcl::dict::get $rinfo instruction]
set insert_mode [tcl::dict::get $rinfo insert_mode]
set autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;#
set reverse_mode [tcl::dict::get $rinfo reverse_mode]
set instruction [tcl::dict::get $rinfo instruction]
tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode]
tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode]
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;#
tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode]
#how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack?
# - review - the answer is probably that we don't need to - it is set/reset only during application of overtext
set crm_mode [tcl::dict::get $rinfo crm_mode]
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set overflow_right_column [tcl::dict::get $rinfo overflow_right_column]
set unapplied [tcl::dict::get $rinfo unapplied]
set unapplied_list [tcl::dict::get $rinfo unapplied_list]
set post_render_col [tcl::dict::get $rinfo cursor_column]
set post_render_row [tcl::dict::get $rinfo cursor_row]
set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position]
set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes]
set visualwidth [tcl::dict::get $rinfo visualwidth]
set insert_lines_above [tcl::dict::get $rinfo insert_lines_above]
set insert_lines_below [tcl::dict::get $rinfo insert_lines_below]
tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay]
#Note carefully the difference betw overflow_right and unapplied.
#overflow_right may need to be included in next run before the unapplied data
#overflow_right most commonly has data when in insert_mode
set rendered [tcl::dict::get $rinfo result]
set overflow_right [tcl::dict::get $rinfo overflow_right]
set overflow_right_column [tcl::dict::get $rinfo overflow_right_column]
set unapplied [tcl::dict::get $rinfo unapplied]
set unapplied_list [tcl::dict::get $rinfo unapplied_list]
set post_render_col [tcl::dict::get $rinfo cursor_column]
set post_render_row [tcl::dict::get $rinfo cursor_row]
set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position]
set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes]
set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line
set insert_lines_above [tcl::dict::get $rinfo insert_lines_above]
set insert_lines_below [tcl::dict::get $rinfo insert_lines_below]
tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay]
#lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay]
set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]
if {0 && $reverse_mode} {
if {0 && [tcl::dict::get $vtstate reverse_mode]} {
#test branch - todo - prune
puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered"
#review
@ -593,19 +598,29 @@ tcl::namespace::eval overtype {
#todo - handle potential insertion mode as above for cursor restore?
#keeping separate branches for debugging - review and merge as appropriate when stable
tcl::dict::incr instruction_stats $instruction
switch -- $instruction {
set instruction_type [lindex $instruction 0] ;#some instructions have params
tcl::dict::incr instruction_stats $instruction_type
switch -- $instruction_type {
reset {
#reset the 'renderspace terminal' (not underlying terminal)
set row 1
set col 1
set vtstate [tcl::dict::merge $vtstate $initial_state]
#todo - clear screen
}
{} {
#end of supplied line input
#lf included in data
set row $post_render_row
set col $post_render_col
if {![llength $unapplied_list]} {
if {$overflow_right ne ""} {
incr row
}
} else {
puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)"
}
set col $opt_startcolumn
}
up {
@ -708,17 +723,18 @@ tcl::namespace::eval overtype {
puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]"
set sub_info [overtype::renderline -info 1\
-width $renderwidth\
-insert_mode $insert_mode\
-autowrap_mode $autowrap_mode\
set sub_info [overtype::renderline\
-info 1\
-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]\
""\
$overflow_right\
]
set foldline [tcl::dict::get $sub_info result]
set insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
set autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
set foldline [tcl::dict::get $sub_info result]
tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..?
tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this..
linsert outputlines $renderedrow $foldline
#review - row & col set by restore - but not if there was no save..
}
@ -745,6 +761,53 @@ tcl::namespace::eval overtype {
set col $post_render_col
#overflow + unapplied?
}
clear_and_move {
#e.g 2J
if {$post_render_row > [llength $outputlines]} {
set row [llength $outputlines]
} else {
set row $post_render_row
}
set col $post_render_col
set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant
set clearedlines [list]
foreach ln $outputlines {
lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m
if 0 {
set lineparts [punk::ansi::ta::split_codes $ln]
set numcells 0
foreach {pt _code} $lineparts {
if {$pt ne ""} {
foreach grapheme [punk::char::grapheme_split $pt] {
switch -- $grapheme {
" " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? -
a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y -
z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
incr numcells 1
}
default {
if {$grapheme eq "\u0000"} {
incr numcells 1
} else {
incr numcells [grapheme_width_cached $grapheme]
}
}
}
}
}
}
#replays/resets each line
lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m
}
}
set outputlines $clearedlines
#todo - determine background/default to be in effect - DECECM ?
puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]"
#lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0]
}
lf_start {
#raw newlines
# ----------------------
@ -780,27 +843,48 @@ tcl::namespace::eval overtype {
append rendered $overflow_right
set overflow_right ""
} else {
#review - we should really make renderline do the work...?
set overflow_width [punk::ansi::printing_length $overflow_right]
if {$visualwidth + $overflow_width <= $renderwidth} {
append rendered $overflow_right
set overflow_right ""
} else {
if {$visualwidth < $renderwidth} {
set graphemes [punk::char::grapheme_split $overflow_width]
set add ""
set addlen $visualwidth
set remaining_overflow $graphemes
foreach g $graphemes {
set w [overtype::grapheme_width_cached]
if {$addlen + $w <= $renderwidth} {
append add $g
incr addlen $w
lpop remaining_overflow
} else {
break
}
if {[tcl::dict::get $vtstate autowrap_mode]} {
set outputlines [linsert $outputlines $renderedrow $overflow_right]
set overflow_right ""
set row [expr {$renderedrow + 2}]
} else {
set overflow_right "" ;#abandon
}
if {0 && $visualwidth < $renderwidth} {
puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth"
error "incomplete - abandon?"
set overflowparts [punk::ansi::ta::split_codes $overflow_right]
set remaining_overflow $overflowparts
set filled 0
foreach {pt code} $overflowparts {
lpop remaining_overflow 0
if {$pt ne ""} {
set graphemes [punk::char::grapheme_split $pt]
set add ""
set addlen $visualwidth
foreach g $graphemes {
set w [overtype::grapheme_width_cached $g]
if {$addlen + $w <= $renderwidth} {
append add $g
incr addlen $w
} else {
set filled 1
break
}
}
append rendered $add
}
if {!$filled} {
lpop remaining_overflow 0 ;#pop code
}
}
append rendered $add
set overflow_right [join $remaining_overflow ""]
}
}
@ -829,14 +913,16 @@ tcl::namespace::eval overtype {
#we may also have other control sequences that came after col 80 e.g cursor save
if 0 {
set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]]
set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs]
set rhs ""
set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]]
set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs]
set rhs ""
#assertion - there should be no overflow..
puts $lhs
#assertion - there should be no overflow..
puts $lhs
}
if {![tcl::dict::get $vtstate insert_mode]} {
assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode
}
assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right
set row $post_render_row
#set row $renderedrow
@ -981,7 +1067,7 @@ tcl::namespace::eval overtype {
#normal single-width grapheme overflow
#puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]"
set row $post_render_row ;#renderline will not advance row when reporting overflow char
if {$autowrap_mode} {
if {[tcl::dict::get $vtstate autowrap_mode]} {
incr row
set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ??
} else {
@ -1014,7 +1100,7 @@ tcl::namespace::eval overtype {
#2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts
#todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc
if {$autowrap_mode} {
if {[tcl::dict::get $vtstate autowrap_mode]} {
if {$renderwidth < 2} {
#edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character
set idx 0
@ -1055,6 +1141,14 @@ tcl::namespace::eval overtype {
set row $post_render_row
set col $post_render_col
}
set_window_title {
set newtitle [lindex $instruction 1]
puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'"
#
}
reset_colour_palette {
puts stderr "overtype::renderspace instruction '$instruction' unimplemented"
}
default {
puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'"
}
@ -1062,7 +1156,7 @@ tcl::namespace::eval overtype {
}
if {!$opt_expand_right && !$autowrap_mode} {
if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} {
#not allowed to overflow column or wrap therefore we get overflow data to truncate
if {[tcl::dict::get $opts -ellipsis]} {
set show_ellipsis 1
@ -1160,11 +1254,22 @@ tcl::namespace::eval overtype {
}
set result [join $outputlines \n]
if {$info_mode} {
if {!$opt_info} {
return $result
} else {
#emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window?
#append result \n$instruction_stats\n
set inforesult [dict create\
result $result\
last_instruction $instruction\
instruction_stats $instruction_stats\
]
if {$opt_info == 2} {
return [pdict -channel none inforesult]
} else {
return $inforesult
}
}
return $result
}
#todo - left-right ellipsis ?
@ -2368,14 +2473,22 @@ tcl::namespace::eval overtype {
} else {
#linefeed occurred in middle or at end of text
#puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx"
incr cursor_row
if {$idx == -1 || $overflow_idx > $idx} {
#don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
if {$insert_mode == 0} {
incr cursor_row
if {$idx == -1 || $overflow_idx > $idx} {
#don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow
set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1
}
set instruction lf_mid
priv::render_unapplied $overlay_grapheme_control_list $gci
break
} else {
incr cursor_row
#don't adjust the overflow_idx
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction lf_mid
break ;# could have overdata following the \n - don't keep processing
}
set instruction lf_mid
priv::render_unapplied $overlay_grapheme_control_list $gci
break
}
}
@ -3077,8 +3190,11 @@ tcl::namespace::eval overtype {
set idx [expr {$cursor_column -1}]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
if {[llength $outcols]} {
priv::render_erasechar 0 [llength $outcols]
}
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction move
set instruction clear_and_move
break
}
3 {
@ -3749,6 +3865,72 @@ tcl::namespace::eval overtype {
}
7OSC - 8OSC {
# OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit
if {[tcl::string::index $codenorm end] eq "\007"} {
set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007
} else {
set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\
}
set first_colon [tcl::string::first {;} $code_content]
if {$first_colon == -1} {
#there probably should always be a colon - but we'll try to make sense of it without
set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007
} else {
set osc_code [tcl::string::range $code_content 0 $first_colon-1]
}
switch -exact -- $osc_code {
2 {
set newtitle [tcl::string::range $code_content 2 end]
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction [list set_window_title $newtitle]
break
}
4 {
#OSC 4 - set colour palette
#can take multiple params
#e.g \x1b\]4\;1\;red\;2\;green\x1b\\
set params [tcl::string::range $code_content 1 end]
puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 {
#OSC 10 through 17 - so called 'dynamic colours'
#can take multiple params - each successive parameter changes the next colour in the list
#- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more
#10 change text foreground colour
#11 change text background colour
#12 change text cursor colour
#13 change mouse foreground colour
#14 change mouse background colour
#15 change tektronix foreground colour
#16 change tektronix background colour
#17 change highlight colour
set params [tcl::string::range $code_content 2 end]
puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
18 {
#why is this not considered one of the dynamic colours above?
#https://www.xfree86.org/current/ctlseqs.html
#tektronix cursor color
puts stderr "overtype::renderline OSC 18 - set tektronix cursor color 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
puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
priv::render_unapplied $overlay_grapheme_control_list $gci
set instruction [list reset_colour_palette]
break
}
default {
puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
}
default {
@ -3791,6 +3973,23 @@ tcl::namespace::eval overtype {
#how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW
set in_overflow 1
}
set trailing_nulls 0
foreach ch [lreverse $outcols] {
if {$ch eq "\u0000"} {
incr trailing_nulls
} else {
break
}
}
if {$trailing_nulls} {
set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}]
} else {
set first_tail_null_posn -1
}
#puts stderr "first_tail_null_posn: $first_tail_null_posn"
#puts stderr "colview: [ansistring VIEW $outcols]"
foreach ch $outcols {
#puts "---- [ansistring VIEW $ch]"
@ -3865,8 +4064,17 @@ tcl::namespace::eval overtype {
}
append outstring $gxleader
append outstring $sgrleader
if {$idx+1 < $cursor_column} {
append outstring [tcl::string::map {\u0000 " "} $ch]
if {$ch eq "\u0000"} {
if {$cp437_glyphs} {
#map all nulls including at tail to space
append outstring " "
} else {
if {$trailing_nulls && $i < $first_tail_null_posn} {
append outstring " " ;#map inner nulls to space
} else {
append outstring \u0000
}
}
} else {
append outstring $ch
}
@ -3874,12 +4082,20 @@ tcl::namespace::eval overtype {
incr i
}
#flower.ans good test for null handling - reverse line building
if {![ansistring length $overflow_right]} {
set outstring [tcl::string::trimright $outstring "\u0000"]
}
set outstring [tcl::string::map {\u0000 " "} $outstring]
set overflow_right [tcl::string::trimright $overflow_right "\u0000"]
set overflow_right [tcl::string::map {\u0000 " "} $overflow_right]
#review - presence of overflow_right doesn't indicate line's trailing nulls should remain.
#The cells could have been erased?
#if {!$cp437_glyphs} {
# #if {![ansistring length $overflow_right]} {
# # set outstring [tcl::string::trimright $outstring "\u0000"]
# #}
# set outstring [tcl::string::trimright $outstring "\u0000"]
# set outstring [tcl::string::map {\u0000 " "} $outstring]
#}
#REVIEW
#set overflow_right [tcl::string::trimright $overflow_right "\u0000"]
#set overflow_right [tcl::string::map {\u0000 " "} $overflow_right]
set replay_codes ""
if {[llength $understacks] > 0} {
@ -4207,8 +4423,9 @@ tcl::namespace::eval overtype::priv {
upvar outcols o
upvar understacks ustacks
upvar understacks_gx gxstacks
upvar replay_codes_overlay replay
#ECH clears character attributes from erased character positions
#ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater.
#ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater.
if {![tcl::string::is integer -strict $count] || $count < 1} {
error "render_erasechar count must be integer >= 1"
}
@ -4223,8 +4440,9 @@ tcl::namespace::eval overtype::priv {
}
set num [expr {$end - $start + 1}]
set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space?
set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list]]]
set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]]
#DECECM ???
set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]]
set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review
return
}
proc render_setchar {i c } {

18
src/vfs/_vfscommon/modules/punk/aliascore-0.1.0.tm

@ -102,6 +102,8 @@ tcl::namespace::eval punk::aliascore {
variable aliases
#use absolute ns ie must be prefixed with ::
#single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased
#functions must be in export list of their source namespace
set aliases [tcl::dict::create\
tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\
@ -109,11 +111,23 @@ tcl::namespace::eval punk::aliascore {
linelist ::punk::lib::linelist\
linesort ::punk::lib::linesort\
pdict ::punk::lib::pdict\
plist [list ::punk::lib::pdict -roottype list]\
showlist [list ::punk::lib::showdict -roottype list]\
plist {::punk::lib::pdict -roottype list}\
showlist {::punk::lib::showdict -roottype list}\
showdict ::punk::lib::showdict\
ansistrip ::punk::ansi::ansistrip\
stripansi ::punk::ansi::ansistrip\
ansiwrap ::punk::ansi::ansiwrap\
colour ::punk::console::colour\
ansi ::punk::console::ansi\
color ::punk::console::colour\
a+ ::punk::console::code_a+\
A+ {::punk::console::code_a+ forcecolour}\
a ::punk::console::code_a\
A {::punk::console::code_a forcecolour}\
a? ::punk::console::code_a?\
A? {::punk::console::code_a? forcecolor}\
smcup ::punk::console::enable_alt_screen\
rmcup ::punk::console::disable_alt_screen\
]
#*** !doctools

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

@ -413,6 +413,7 @@ tcl::namespace::eval punk::ansi {
tcl::namespace::export\
{a?} {a+} a \
ansistring\
ansiwrap\
convert*\
clear*\
cursor_*\
@ -722,77 +723,11 @@ tcl::namespace::eval punk::ansi {
#candidate for zig/c implementation?
proc stripansi2 {text} {
set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters
join [::punk::ansi::ta::split_at_codes $text] ""
}
proc stripansi1 {text} {
#todo - character set selection - SS2 SS3 - how are they terminated? REVIEW
variable escape_terminals ;#dict
variable ::punk::ansi::ta::standalone_code_map ;#map to empty string
set text [convert_g0 $text]
set text [tcl::string::map $standalone_code_map $text]
#e.g standalone 2 byte and 3 byte VT100(?) sequences - some of these work in wezterm
#\x1b#3 double-height letters top half
#\x1b#4 double-height letters bottom half
#\x1b#5 single-width line
#\x1b#6 double-width line
#\x1b#8 dec test fill screen
#we process char by char - line-endings whether \r\n or \n should be processed as per any other character.
#Theoretically line endings can occur within an ST payload (review e.g title?)
#ecma standard says: The character string following may consist of any bit combination, except those representing SOS or STRING TERMINATOR (ST)
set inputlist [split $text ""]
set outputlist [list]
set in_escapesequence 0
#assumption - text already 'rendered' - ie no cursor movement controls . (what about backspace and lone carriage returns - they are horizontal cursor movements)
set i 0
foreach u $inputlist {
set v [lindex $inputlist $i+1]
set uv ${u}${v}
if {$in_escapesequence eq "2b"} {
#2nd byte - done.
set in_escapesequence 0
} elseif {$in_escapesequence != 0} {
set endseq [tcl::dict::get $escape_terminals $in_escapesequence]
if {$u in $endseq} {
set in_escapesequence 0
} elseif {$uv in $endseq} {
set in_escapesequence 2b ;#flag next byte as last in sequence
}
} else {
#handle both 7-bit and 8-bit CSI and OSC
if {[regexp {^(?:\033\[|\u009b)} $uv]} {
set in_escapesequence CSI
} elseif {[regexp {^(?:\033\]|\u009d)} $uv]} {
set in_escapesequence OSC
} elseif {[regexp {^(?:\033P|\u0090)} $uv]} {
set in_escapesequence DCS
} elseif {[regexp {^(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)} $uv]} {
#SOS,PM,APC - all terminated with ST
set in_escapesequence MISC
} else {
lappend outputlist $u
}
}
incr i
}
return [join $outputlist ""]
}
#review - what happens when no terminator?
#todo - map other character sets to unicode equivs? There seems to be little support for other than the DEC special graphics set.. ISO2022 character switching not widely supported - may be best considered deprecated(?)
# convert esc(0 -> esc(B graphics sequences to single char unicode equivalents e.g box drawing set
@ -2029,7 +1964,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#[para]Return an ansi string representing a table of codes and a panel showing the colours
variable SGR_setting_map
variable SGR_colour_map
set fcposn [lsearch $args "forcecol*"]
set fcposn [lsearch $args "force*"]
set fc ""
set opt_forcecolour 0
if {$fcposn >= 0} {
@ -2409,7 +2344,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything.
set forcecolour 0
set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour
set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour
if {$fcpos >= 0} {
set forcecolour 1
set args [lremove $args $fcpos]
@ -2767,7 +2702,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything.
set forcecolour 0
set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour
set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour
if {$fcpos >=0} {
set forcecolour 1
set args [lremove $args $fcpos]
@ -3199,6 +3134,16 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
return $out
}
proc move_emitblock {row col textblock} {
#*** !doctools
#[call [fun move_emitblock] [arg row] [arg col] [arg textblock]]
set commands ""
foreach ln [split $textblock \n] {
append commands [punk::ansi::move_emit $row $col $ln]
incr row
}
return $commands
}
proc move_forward {{n 1}} {
#*** !doctools
#[call [fun move_forward] [arg n]]
@ -3315,18 +3260,90 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
#Alt screen buffer
#Alt screen buffer - smcup/rmcup ti/te
#Note \x1b\[?47h doesn't work at all in some terminals (e.g alacritty,cmd on windows and reportedly kitty)
#It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals.
#see: https://xn--rpa.cc/irl/term.html
#1049 (introduced by xterm in 1998?) considered the more modern version?
#1047,1048,1049 xterm private modes are 'composite' control sequences as replacement for original 47 sequence
#1049 - includes save cursor,switch to alt screen, clear screen
#e.g ? (below example not known to be exactly what 1049 does - but it's something similar)
#SMCUP
# \x1b7 (save cursor)
# \x1b\[?47h (switch)
# \x1b\[2J (clear screen)
#RMCUP
# \x1b\[?47l (switch back)
# \x1b8 (restore cursor)
#1047 - clear screen on the way out (ony if actually on alt screen)
proc enable_alt_screen {} {
#tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen?
#\x1b\[?1049h ;#xterm
return \x1b\[?47h
return \x1b\[?1049h
}
proc disable_alt_screen {} {
#tput rmcup outputs \x1b\[?1049l\x1b\[23\;0\;0t]
#\x1b\[?1049l
return \x1b\[?1049l
}
#47 - less widely supported(?) doesn't restore cursor or clear alt screen
proc enable_alt_screen2 {} {
return \x1b\[?47h
}
proc disable_alt_screen2 {} {
return \x1b\[?47l
}
proc term_colour_fg {colour} {
return "\x1b\]10\;$colour\x1b\\"
}
proc term_color_fg {colour} {
return "\x1b\]10\;$colour\x1b\\"
}
proc term_colour_bg {colour} {
return "\x1b\]11\;$colour\x1b\\"
}
proc term_color_bg {colour} {
return "\x1b\]11\;$colour\x1b\\"
}
proc term_colour_cursor {colour} {
return "\x1b\]12\;$colour\x1b\\"
}
proc term_color_cursor {colour} {
return "\x1b\]12\;$colour\x1b\\"
}
proc term_colour_pointer_fg {colour} {
return "\x1b\]13\;$colour\x1b\\"
}
proc term_color_pointer_fg {colour} {
return "\x1b\]13\;$colour\x1b\\"
}
proc term_colour_pointer_bg {colour} {
return "\x1b\]14\;$colour\x1b\\"
}
proc term_color_pointer_bg {colour} {
return "\x1b\]14\;$colour\x1b\\"
}
#15,16 tektronix fg, tektronix bg ???
proc term_colour_highlight_bg {colour} {
return "\x1b\]17\;$colour\x1b\\"
}
proc term_color_highlight_bg {colour} {
return "\x1b\]17\;$colour\x1b\\"
}
#18 tektronix cursor colour ???
proc term_colour_highlight_fg {colour} {
return "\x1b\]19\;$colour\x1b\\"
}
proc term_color_highlight_fg {colour} {
return "\x1b\]19\;$colour\x1b\\"
}
#22 pointer shape - there are other methods too - not known to work on windows terminal based VTs - review
proc term_colour_reset {} {
return "\x1b\]104\;\x1b\\"
}
proc term_color_reset {} {
return "\x1b\]104\;\x1b\\"
}
# -- --- ---
proc erase_line {} {
@ -4398,6 +4415,10 @@ tcl::namespace::eval punk::ansi::ta {
variable re_ansi_detect_open
expr {[regexp $re_ansi_detect_open $text]}
}
proc detect_st_open {text} {
variable re_ST_open
expr {[regexp $re_ST_open $text]}
}
#not in perl ta
proc detect_csi {text} {
@ -4672,7 +4693,8 @@ tcl::namespace::eval punk::ansi::class {
}
oo::class create base_renderer {
variable o_width
variable o_wrap o_overflow o_appendlines o_looplimit
variable o_autowrap_mode
variable o_overflow o_appendlines o_looplimit
variable o_cursor_column o_cursor_row
#variable o_render_index ;#index of input (from_ansistring) grapheme/ansi-code that *has* been rendered
@ -4690,25 +4712,33 @@ tcl::namespace::eval punk::ansi::class {
}
tcl::namespace::path $nspath
#-- --
if {[llength $args] < 2} {
error {usage: ?-width <int>? ?-wrap [1|0]? ?-overflow [1|0]? from_ansistring to_ansistring}
if {[llength $args] < 1} {
error {usage: ?-width <int>? ?-height <height>? ?-autowrap_mode [1|0]? ?-overflow [1|0]? from_ansistring}
}
lassign [lrange $args end-1 end] from_ansistring to_ansistring
#lassign [lrange $args end-1 end] from_ansistring to_ansistring
set from_ansistring [lindex $args end]
set opts [tcl::dict::create\
-width \uFFEF\
-wrap 1\
-overflow 0\
-appendlines 1\
-looplimit 15000\
-experimental {}\
-cursor_column 1\
-cursor_row 1\
-width \uFFEF\
-height \uFFEF\
-overflow 0\
-appendlines 1\
-looplimit 15000\
-experimental {}\
-cursor_column 1\
-cursor_row 1\
-insert_mode 0\
-autowrap_mode 1\
-initial_ansistring ""\
]
puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring"
set argsflags [lrange $args 0 end-2]
foreach {k v} $argsflags {
switch -- $k {
-width - -wrap - -overflow - -appendlines - -looplimit - -experimental {
-width - -height -
-overflow - -appendlines - -looplimit - -experimental -
-autowrap_mode -
-insert_mode -
-initial_ansistring {
tcl::dict::set opts $k $v
}
default {
@ -4717,8 +4747,19 @@ tcl::namespace::eval punk::ansi::class {
}
}
}
set initial_ansistring [tcl::dict::get $opts -initial_ansistring]
if {$initial_ansistring eq ""} {
set to_ansistring [punk::ansi::class::class_ansistring new ""]
} else {
#todo - verify obj vs raw string
set to_ansistring $initial_ansistring
}
puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring"
set o_width [tcl::dict::get $opts -width]
set o_wrap [tcl::dict::get $opts -wrap]
set o_height [tcl::dict::get $opts -height]
set o_autowrap_mode [tcl::dict::get $opts -autowrap_mode]
set o_insert_mode [tcl::dict::get $opts -insert_mode]
set o_overflow [tcl::dict::get $opts -overflow]
set o_appendlines [tcl::dict::get $opts -appendlines]
set o_looplimit [tcl::dict::get $opts -looplimit]
@ -4736,6 +4777,9 @@ tcl::namespace::eval punk::ansi::class {
method eval_in {script} {
eval $script
}
method renderbuf {} {
return $o_to_ansistring
}
method cursor_column {{col ""}} {
if {$col eq ""} {
return $o_cursor_column
@ -4755,6 +4799,12 @@ tcl::namespace::eval punk::ansi::class {
set o_cursor_row $row
}
#set/query cursor state
method cursor_state {args} {
lassign $args r c
return [dict create row [my cursor_row $r] column [my cursor_column $c]]
}
#consider scroll area
#we need to render to something with a concept of viewport, offscreen above,below,left,right?
method rendernext {} {
@ -4834,7 +4884,8 @@ tcl::namespace::eval punk::ansi::class {
#set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext]
}
}
#renderspace equivalent? channel based?
#todo
$o_to_ansistring append $newtext
return [tcl::dict::create type $type_rendered rendercount $rendercount start_count_unrendered $start_elements_unrendered end_count_unrendered $end_elements_unrendered]
@ -4960,11 +5011,10 @@ tcl::namespace::eval punk::ansi::class {
if {$o_renderer ne ""} {
append result \n " renderer obj: $o_renderer"
append result \n " renderer class: [info object class $o_renderer]"
}
if {$o_renderout ne ""} {
append result \n " render target ansistring: $o_renderout"
append result \n " render target has ansi : [$o_renderout has_ansi]"
append result \n " render target count : [$o_renderout count]"
set renderstring [$o_renderer renderbuf]
append result \n " render target ansistring: $renderstring"
append result \n " render target has ansi : [$renderstring has_ansi]"
append result \n " render target count : [$renderstring count]"
}
if {$verbose} {
append result \n "ansisplits listing"
@ -5052,7 +5102,8 @@ tcl::namespace::eval punk::ansi::class {
}
method strippedlength {} {
if {![llength $o_ansisplits]} {my MakeSplit}
#review
return [string length [join $o_ptlist ""]]
}
#returns the ansiless string - doesn't affect the stored state other than initialising it's internal state if it wasn't already
method stripped {} {
@ -5119,10 +5170,9 @@ tcl::namespace::eval punk::ansi::class {
if {$rtype ni $rtypes} {
error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)"
}
if {$o_renderout eq ""} {
#tell ansistring that it's a renderbuf for another ansistring? point it to the renderer or the parent ansistring?
set o_renderout [punk::ansi::class::class_ansistring new ""]
}
#if {$o_renderout eq ""} {
# set o_renderout [punk::ansi::class::class_ansistring new ""]
#}
if {$o_renderer ne ""} {
set oinfo [info object class $o_renderer]
set tail [tcl::namespace::tail $oinfo]
@ -5130,13 +5180,15 @@ tcl::namespace::eval punk::ansi::class {
if {$rtype ne $currenttype} {
puts "switch rendertype from $currenttype to $rtype - destroying renderer and creating a new one"
$o_renderer destroy ;#what happens to data in target ansistring obj? when does it make sense to keep output and keep rendering vs clearing?
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
#set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]]
} else {
return $currenttype
}
} else {
puts "creating first renderer"
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
#set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout]
set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]]
}
}
#--- progressive rendering buffer - another ansistring object
@ -5149,10 +5201,13 @@ tcl::namespace::eval punk::ansi::class {
return $o_renderwidth
}
#re-render if needed?
puts stderr "renderwidth todo? re-render?"
set o_renderwidth $rw
}
method renderer {} {
return $o_renderer
}
method render_state {} {
#? report state of render.. we will primarily be using plaintext/ansisequence as the chunk/operation boundary
#but - as we can append char sequences directly to the tail split - it's not enough to track which split element we have rendered - but we also need how many graphemes or code sequences we are into the last split.
@ -5160,10 +5215,36 @@ tcl::namespace::eval punk::ansi::class {
}
method renderbuf {} {
#get the underlying renderobj - if any
return $o_renderout ;#also class_ansistring
#return $o_renderout ;#also class_ansistring
return [$o_renderer renderbuf]
}
method render {} {
method render {{maxgraphemes ""}} {
#full render - return buffer ansistring
set do_render 1
set grapheme_count 0
set other_count 0
if {$maxgraphemes eq ""} {
while {$do_render} {
set rendition [my rendernext]
set do_render [dict get $rendition rendercount]
if {[dict get $rendition type] eq "g"} {
incr grapheme_count $do_render
} else {
incr other_count $do_render
}
}
} else {
while {$do_render && $grapheme_count <= $maxgraphemes} {
set rendition [my rendernext]
set do_render [dict get $rendition rendercount]
if {[dict get $rendition type] eq "g"} {
incr grapheme_count $do_render
} else {
incr other_count $do_render
}
}
}
return [dict create graphemes $grapheme_count other $other_count]
}
method rendernext {} {
#render next available pt/code chunk only - not to end of available input
@ -5198,6 +5279,13 @@ tcl::namespace::eval punk::ansi::class {
#i.e a 'rendered' ANSI string should contain just ANSI SGR character attributes and linefeeds for rows
#Knowing which is which can be helpful as far as use of any methods which use the concepts of terminal row/column
#like Tcl's append class_ansistring append returns the result directly - which for ANSI - can be inconvenient in the terminal
#class_ansistring append_string is a convenience wrapper to avoid returning the raw result
method append_string {args} {
my append {*}$args
return
}
#analagous to Tcl string append
#MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient
method append {args} {
@ -5369,7 +5457,7 @@ tcl::namespace::eval punk::ansi::class {
}
#method append_and_render - append and render up to end of appended data at same time
#method append_and_render? - append and render up to end of appended data at same time
method view {args} {
if {$o_string eq ""} {

6
src/vfs/_vfscommon/modules/punk/blockletter-0.1.0.tm

@ -20,12 +20,14 @@
#*** !doctools
#[manpage_begin shellspy_module_punk::blockletter 0 0.1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[titledesc {punk::blockletter frame-based large lettering test/logo}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require punk::blockletter]
#[keywords module]
#[description]
#[para] -
#[para] This is primarily designed to test large lettering using the block2 frametype which requires the right font support
#[para] More reasonably sized block-lettering could be obtained using unicode half-blocks instead - but that doesn't allow the frame outline effect that block2 gives.
#[para] Individual blocks have a minimum width of 4 columns and a minimum height of 2 rows (smallest element that can be fully framed)
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++

19
src/vfs/_vfscommon/modules/punk/config-0.1.tm

@ -60,12 +60,19 @@ tcl::namespace::eval punk::config {
}
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run
#optional channel transforms on stdout/stderr.
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands
#If no distinction necessary - should use default_color_<chan>
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation.
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default
set default_color_stdout ""
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc)
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful.
#set default_color_stderr "red bold"
#set default_color_stderr "web-lightsalmon"
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive
set default_color_stderr_repl "" ;#during repl call only
set homedir ""
if {[catch {
@ -132,7 +139,9 @@ tcl::namespace::eval punk::config {
configset ".punkshell"\
scriptlib $default_scriptlib\
color_stdout $default_color_stdout\
color_stdout_repl $default_color_stdout_repl\
color_stderr $default_color_stderr\
color_stderr_repl $default_color_stderr_repl\
logfile_stdout $default_logfile_stdout\
logfile_stderr $default_logfile_stderr\
logfile_active 0\
@ -172,9 +181,11 @@ tcl::namespace::eval punk::config {
PUNK_CONFIGSET {type string}\
PUNK_SCRIPTLIB {type string}\
PUNK_AUTO_EXEC_MECHANISM {type string}\
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\
PUNK_COLOR_STDERR {type string}\
PUNK_COLOR_STDOUT {type string}\
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\
PUNK_LOGFILE_STDOUT {type string}\
PUNK_LOGFILE_STDERR {type string}\
PUNK_LOGFILE_ACTIVE {type string}\

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

@ -864,6 +864,7 @@ namespace eval punk::console {
#Turning ansi off only stops new ansi being generated - but what about codes stored in configurations of existing elements such as tables/frames?
#It will stop underlines/bold/reverse as well as SGR colours
#what about ansi movement codes etc?
#we already have colour on|off which disables SGR codes in a+ etc as well as stderr/stdout channel transforms
proc ansi {{onoff {}}} {
variable ansi_wanted
if {[string length $onoff]} {
@ -891,6 +892,7 @@ namespace eval punk::console {
}
}
catch {punk::repl::reset_prompt}
puts stderr "::punk::console::ansi - use 'colour' command to turn SGR codes on/off"
return [expr {$ansi_wanted}]
}
@ -1295,10 +1297,10 @@ namespace eval punk::console {
if {![catch {twapi::set_console_title $windowtitle} result]} {
return $windowtitle
} else {
error "punk::console::titleset failed to set title - try punk::console::ansi::titleset"
error "punk::console::local::titleset failed to set title - try punk::console::ansi::titleset"
}
} else {
error "punk::console::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset"
error "punk::console::local::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset"
}
}
proc titleget {} {
@ -1306,12 +1308,12 @@ namespace eval punk::console {
if {![catch {twapi::get_console_title} result]} {
return $result
} else {
error "punk::console::titleset failed to set title - ensure twapi is available"
error "punk::console::local::titleset failed to set title - ensure twapi is available"
}
} else {
#titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title
# won't work on all platforms/terminals - but may be worth implementing
error "punk::console::titleget has no local mechanism to get the window title on this platform."
# won't work on all platforms/terminals - but may be worth implementing (for overtype::renderspace / frames etc)
error "punk::console::local::titleget has no local mechanism to get the window title on this platform."
}
}
}
@ -1327,7 +1329,7 @@ namespace eval punk::console {
if { $ansi_wanted <= 0} {
punk::console::local::titleset $windowtitle
} else {
tailcall ansi::titleset $windowtitle
ansi::titleset $windowtitle
}
}
#no known pure-ansi solution
@ -1486,8 +1488,6 @@ namespace eval punk::console {
namespace import ansi::insert_lines
namespace import ansi::delete_lines
interp alias {} smcup {} ::punk::console::enable_alt_screen
interp alias {} rmcup {} ::punk::console::disable_alt_screen
#experimental
proc rhs_prompt {col text} {
@ -1881,12 +1881,6 @@ namespace eval punk::console {
interp alias {} colour {} punk::console::colour
interp alias {} ansi {} punk::console::ansi
interp alias {} color {} punk::console::colour
interp alias {} a+ {} punk::console::code_a+
interp alias {} a {} punk::console::code_a
interp alias {} a? {} punk::console::code_a?

5
src/vfs/_vfscommon/modules/punk/nav/fs-0.1.0.tm

@ -219,7 +219,8 @@ tcl::namespace::eval punk::nav::fs {
}
if {[punk::nav::fs::system::codethread_is_running]} {
if {[llength [info commands ::punk::console::titleset]]} {
::punk::console::titleset [lrange $result 1 end]
#if ansi is off - punk::console::titleset will try 'local' api method - which can fail
catch {::punk::console::titleset [lrange $result 1 end]}
}
}
if {[string match //zipfs:/* $location]} {
@ -489,7 +490,7 @@ tcl::namespace::eval punk::nav::fs {
tsv::lappend repl runchunks-$repl_runid {*}$chunklist
}
if {[llength [info commands ::punk::console::titleset]]} {
::punk::console::titleset [lrange $result 1 end] ;#strip location key
catch {::punk::console::titleset [lrange $result 1 end]} ;#strip location key
}
}
if {$repl_runid == 0} {

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

@ -1561,7 +1561,8 @@ tcl::namespace::eval punk::ns {
#set name [string trim $name :]
#set origin [namespace origin ${upns}::$name]
set origin [nseval $targetns [list ::namespace origin $name]]
set origin [nseval $targetns [list ::namespace origin $name]]
set resolved [nseval $targetns [list ::namespace which $name]]
#An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases!
if {$origin ni [info procs $origin]} {
@ -1613,7 +1614,8 @@ tcl::namespace::eval punk::ns {
}
lappend argl $a
}
list proc [nsjoin ${targetns} $name] $argl $body
#list proc [nsjoin ${targetns} $name] $argl $body
list proc $resolved $argl $body
}

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

@ -31,7 +31,9 @@ package require shellfilter
#package require punk
package require punk::lib
package require punk::aliascore
punk::aliascore::init
if {[catch {punk::aliascore::init} errM]} {
puts stderr "punk::aliascore::init error: $errM"
}
package require punk::config
package require punk::ns
package require punk::ansi
@ -2576,8 +2578,41 @@ namespace eval repl {
}
}
proc colour args {
thread::send %replthread% [list punk::console::colour {*}$args]
interp eval code [list punk::console::colour {*}$args]
set colour_state [thread::send %replthread% [list punk::console::colour]]
if {[llength $args]} {
#colour call was not a query
set new_state [thread::send %replthread% [list punk::console::colour {*}$args]]
if {[expr {$new_state}] ne [expr {$colour_state}]} {
interp eval code [list punk::console::colour {*}$args] ;#align code interp's view of colour state with repl thread
interp eval code [string map [list <cstate> $new_state] {
#adjust channel transform stack
set docolour [expr {<cstate>}]
if {!$docolour} {
set s [lindex $::codeinterp::outstack end]
if {$s ne ""} {
shellfilter::stack::remove stdout $s
}
set s [lindex $::codeinterp::errstack end]
if {$s ne ""} {
shellfilter::stack::remove stderr $s
}
} else {
set running_config $::punk::config::running
if {[string length [dict get $running_config color_stdout]]} {
lappend ::codeinterp::outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]]
}
if {[string length [dict get $running_config color_stderr]]} {
lappend ::codeinterp::errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]]
}
}
}]
}
return $new_state
} else {
return $colour_state
}
#todo - add/remove shellfilter stacked ansiwrap
}
proc mode args {
thread::send %replthread% [list punk::console::mode {*}$args]
@ -2686,6 +2721,10 @@ namespace eval repl {
#review argv0,argv,argc
interp eval code {
namespace eval ::codeinterp {
variable errstack {}
variable outstack {}
}
set ::argv0 %argv0%
set ::auto_path %autopath%
#puts stdout "safe interp"
@ -2724,6 +2763,10 @@ namespace eval repl {
set ::auto_path %autopath%
#puts stdout "safe interp"
#flush stdout
namespace eval ::codeinterp {
variable errstack {}
variable outstack {}
}
}
interp eval code [list set ::tcl_platform(os) $::tcl_platform(os)]
interp eval code [list set ::tcl_platform(osVersion) $::tcl_platform(osVersion)]
@ -2775,7 +2818,11 @@ namespace eval repl {
set ::auto_path %autopath%
tcl::tm::remove {*}[tcl::tm::list]
tcl::tm::add {*}[lreverse %tmlist%]
#puts "-->[chan names]"
puts "code interp chan names-->[chan names]"
namespace eval ::codeinterp {
variable errstack {}
variable outstack {}
}
# -- ---
#review
@ -2805,11 +2852,22 @@ namespace eval repl {
#catch {package require packageTrace}
package require punk
package require shellrun
package require shellfilter
set running_config $::punk::config::running
if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} {
lappend ::codeinterp::errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]]
}
if {[string length [dict get $running_config color_stdout]] && [punk::console::colour]} {
lappend ::codeinterp::outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]]
}
package require textblock
} errM]} {
puts stderr "========================"
puts stderr "code interp error:"
puts stderr $errM
puts stderr $::errorInfo
puts stderr "========================"
error "$errM"
}

26
src/vfs/_vfscommon/modules/punk/repl/codethread-0.1.0.tm

@ -151,16 +151,19 @@ tcl::namespace::eval punk::repl::codethread {
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread"
return
}
set outstack [list]
set errstack [list]
upvar ::punk::config::running running_config
if {[string length [dict get $running_config color_stdout]] && [punk::console::colour]} {
lappend outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]]
if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} {
lappend outstack [interp eval code [list shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]]
}
lappend outstack [shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]
if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} {
lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]]
#lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]]
lappend outstack [interp eval code [list shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]]
if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} {
lappend errstack [interp eval code [list shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]]
# #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]]
}
lappend errstack [shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]
lappend errstack [interp eval code [list shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]]
#an experiment
#set errhandle [shellfilter::stack::item_tophandle stderr]
@ -177,8 +180,8 @@ tcl::namespace::eval punk::repl::codethread {
#interp transfer code $errhandle ""
#flush $errhandle
set lastoutchar [string index [punk::ansi::ansistrip $output_stdout] end]
set lasterrchar [string index [punk::ansi::ansistrip $output_stderr] end]
set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end]
set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end]
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]"
set tid [thread::id]
@ -188,11 +191,12 @@ tcl::namespace::eval punk::repl::codethread {
tsv::set codethread_$tid errorcode $::errorCode
#only remove from shellfilter::stack the items we added to stack in this function
foreach s [lreverse $outstack] {
shellfilter::stack::remove stdout $s
interp eval code [list shellfilter::stack::remove stdout $s]
}
foreach s [lreverse $errstack] {
shellfilter::stack::remove stderr $s
interp eval code [list shellfilter::stack::remove stderr $s]
}
thread::cond notify $replthread_cond
}

296
src/vfs/_vfscommon/modules/punk/rest-0.1.0.tm

@ -0,0 +1,296 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) DKF (based on DKF's REST client support class)
# (C) 2024 JMN - packaging/possible mods
#
# @@ Meta Begin
# Application punk::rest 0.1.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::rest 0 0.1.0]
#[copyright "2024"]
#[titledesc {punk::rest}] [comment {-- Name section and table of contents description --}]
#[moddesc {experimental rest}] [comment {-- Description at end of page heading --}]
#[require punk::rest]
#[keywords module rest http]
#[description]
#[para] Experimental *basic rest as wrapper over http lib - use tcllib's rest package for a more complete implementation of a rest client
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::rest
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::rest
#[list_begin itemized]
package require Tcl 8.6-
package require http
#*** !doctools
#[item] [package {Tcl 8.6}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::rest::class {
#*** !doctools
#[subsection {Namespace punk::rest::class}]
#[para] class definitions
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::rest {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
#*** !doctools
#[subsection {Namespace punk::rest}]
#[para] Core API functions for punk::rest
#[list_begin definitions]
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1
# #[para] Arguments:
# # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n.
# # [list_end]
# return "ok"
#}
set objname [namespace current]::matrixchain
if {$objname ni [info commands $objname]} {
# Support class for RESTful web services.
# This wraps up the http package to make everything appear nicer.
oo::class create CLIENT {
variable base wadls acceptedmimetypestack
constructor baseURL {
set base $baseURL
my LogWADL $baseURL
}
# TODO: Cookies!
method ExtractError {tok} {
return [http::code $tok],[http::data $tok]
}
method OnRedirect {tok location} {
upvar 1 url url
set url $location
# By default, GET doesn't follow redirects; the next line would
# change that...
#return -code continue
set where $location
my LogWADL $where
if {[string equal -length [string length $base/] $location $base/]} {
set where [string range $where [string length $base/] end]
return -level 2 [split $where /]
}
return -level 2 $where
}
method LogWADL url {
return;# do nothing
set tok [http::geturl $url?_wadl]
set w [http::data $tok]
http::cleanup $tok
if {![info exist wadls($w)]} {
set wadls($w) 1
puts stderr $w
}
}
method PushAcceptedMimeTypes args {
lappend acceptedmimetypestack [http::config -accept]
http::config -accept [join $args ", "]
return
}
method PopAcceptedMimeTypes {} {
set old [lindex $acceptedmimetypestack end]
set acceptedmimetypestack [lrange $acceptedmimetypestack 0 end-1]
http::config -accept $old
return
}
method DoRequest {method url {type ""} {value ""}} {
for {set reqs 0} {$reqs < 5} {incr reqs} {
if {[info exists tok]} {
http::cleanup $tok
}
set tok [http::geturl $url -method $method -type $type -query $value]
if {[http::ncode $tok] > 399} {
set msg [my ExtractError $tok]
http::cleanup $tok
return -code error $msg
} elseif {[http::ncode $tok] > 299 || [http::ncode $tok] == 201} {
set location {}
if {[catch {
set location [dict get [http::meta $tok] Location]
}]} {
http::cleanup $tok
error "missing a location header!"
}
my OnRedirect $tok $location
} else {
set s [http::data $tok]
http::cleanup $tok
return $s
}
}
error "too many redirections!"
}
method GET args {
return [my DoRequest GET $base/[join $args /]]
}
method POST {args} {
set type [lindex $args end-1]
set value [lindex $args end]
set m POST
set path [join [lrange $args 0 end-2] /]
return [my DoRequest $m $base/$path $type $value]
}
method PUT {args} {
set type [lindex $args end-1]
set value [lindex $args end]
set m PUT
set path [join [lrange $args 0 end-2] /]
return [my DoRequest $m $base/$path $type $value]
}
method DELETE args {
set m DELETE
my DoRequest $m $base/[join $args /]
return
}
export GET POST PUT DELETE
}
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::rest ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::rest::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::rest::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::rest::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::rest::system {
#*** !doctools
#[subsection {Namespace punk::rest::system}]
#[para] Internal functions that are not part of the API
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::rest [tcl::namespace::eval punk::rest {
variable pkg punk::rest
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

58
src/vfs/_vfscommon/modules/shellfilter-0.1.9.tm

@ -654,6 +654,7 @@ namespace eval shellfilter::chan {
#detect will detect ansi SGR and gron groff and other codes
if {[punk::ansi::ta::detect $buf]} {
#split_codes_single regex faster than split_codes - but more resulting parts
#'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc)
set parts [punk::ansi::ta::split_codes_single $buf]
#process all pt/code pairs except for trailing pt
foreach {pt code} [lrange $parts 0 end-1] {
@ -725,21 +726,70 @@ namespace eval shellfilter::chan {
} else {
#puts "-->esc but no detect"
#no complete ansi codes - but at least one esc is present
if {[string first \x1b $buf] == [llength $buf]-1} {
if {[string last \x1b $buf] == [llength $buf]-1} {
#only esc is last char in buf
#puts ">>trailing-esc<<"
set o_buffered \x1b
set emit [string range $buf 0 end-1]
} else {
set emit_anyway 0
#todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer
append o_buffered $chunk
set emit ""
if {[punk::ansi::ta::detect_st_open $buf]} {
#no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms)
set st_partial_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code
#todo - configurable ST max - use 1k for now
if {$st_partial_len < 1001} {
append o_buffered $chunk
set emit ""
} else {
set emit_anyway 1
}
} else {
set possible_code_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of possible code
#most opening sequences are 1,2 or 3 chars - review?
set open_sequence_detected [punk::ansi::ta::detect_open $buf]
if {$possible_code_len > 10 && !$open_sequence_detected} {
set emit_anyway 1
} else {
#could be composite sequence with params - allow some reasonable max sequence length
#todo - configurable max sequence length
#len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies
# - allow some headroom for redundant codes when the caller didn't merge.
if {$possible_code_len < 101} {
append o_buffered $chunk
set emit ""
} else {
#allow a little more grace if we at least have an opening ansi sequence of any type..
if {$open_sequence_detected && $possible_code_len < 151} {
append o_buffered $chunk
set emit ""
} else {
set emit_anyway 1
}
}
}
}
if {$emit_anyway} {
#looked ansi-like - but we've given enough length without detecting close..
#treat as possible plain text with some esc or unrecognised ansi sequence
if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} {
set emit $o_do_colour$buf$o_do_normal
} else {
set emit $buf
}
}
}
}
} else {
#no esc
#puts stdout [a+ yellow]...[a]
set emit $buf
#test!
if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} {
set emit $o_do_colour$buf$o_do_normal
} else {
set emit $buf
}
#set emit $buf
set o_buffered ""
}
return [dict create emit $emit stacksize [llength $o_codestack]]

BIN
src/vfs/_vfscommon/modules/test/tomlish-1.1.1.tm

Binary file not shown.

37
src/vfs/_vfscommon/modules/textblock-0.1.1.tm

@ -4041,6 +4041,9 @@ tcl::namespace::eval textblock {
(default 0 if no existing -table supplied)"
-table -default "" -type string -help "existing table object to use"
-headers -default "" -help "list of header values. Must match number of columns"
-show_header -default "" -help "Whether to show a header row.
Leave as empty string for unspecified/automatic,
in which case it will display only if -headers list was supplied."
-action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied
if append is chosen the new values will always start at the first column"
-columns -default "" -type integer -help "Number of table columns
@ -4101,11 +4104,34 @@ tcl::namespace::eval textblock {
}
} else {
set is_new_table 1
set headers {}
if {[tcl::dict::get $opts -headers] ne ""} {
set headers [dict get $opts -headers]
if {[tcl::dict::get $opts -show_header] eq ""} {
set show_header 1
} else {
set show_header [tcl::dict::get $opts -show_header]
}
} else {
if {[tcl::dict::get $opts -show_header] eq ""} {
set show_header 0
} else {
set show_header [tcl::dict::get $opts -show_header]
}
}
if {[tcl::string::is integer -strict $opt_columns]} {
set cols $opt_columns
if {[llength $headers] && $cols != [llength $headers]} {
error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $headers])"
}
} else {
#review
set cols 2 ;#seems a reasonable default
if {[llength $headers]} {
set cols [llength $headers]
} else {
set cols 2 ;#seems a reasonable default
}
}
#defaults for new table only
if {[tcl::dict::get $opts -frametype] eq ""} {
@ -4123,15 +4149,6 @@ tcl::namespace::eval textblock {
if {[tcl::dict::get $opts -show_hseps] eq ""} {
tcl::dict::set opts -show_hseps 0
}
set headers {}
set show_header 0
if {[tcl::dict::get $opts -headers] ne ""} {
set headers [dict get $opts -headers]
if {[llength $headers] ne $cols} {
error "list_as_table number of headers ([llength $headers]) must match number of columns ($cols)"
}
set show_header 1
}
set t [textblock::class::table new\
-show_header $show_header\

1092
src/vfs/_vfscommon/modules/tomlish-1.1.1.tm

File diff suppressed because it is too large Load Diff
Loading…
Cancel
Save